--- /dev/null
+((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))))
# https://www.kernel.org/pub/software/scm/git/docs/git-shortlog.html#_mapping_authors
Alexander Hartmaier <abraxxa@cpan.org> <alexander.hartmaier@t-systems.at>
+Alexander Kuznetsov <acca@cpan.org> <acca(at)cpan.org>
Amiri Barksdale <amiribarksdale@gmail.com> <amiri@metalabel.com>
Andrew Rodland <andrew@cleverdomain.org> <arodland@cpan.org>
Arthur Axel "fREW" Schmidt <frioux@gmail.com>
-Brendan Byrd <Perl@ResonatorSoft.org> <byrd.b@insightcom.com>
-Brendan Byrd <Perl@ResonatorSoft.org> <GitHub@ResonatorSoft.org>
-Brendan Byrd <Perl@ResonatorSoft.org> <perl@resonatorsoft.org>
+Ash Berlin <ash@cpan.org> <ash_github@firemirror.com>
+Brendan Byrd <perl@resonatorsoft.org> <byrd.b@insightcom.com>
+Brendan Byrd <perl@resonatorsoft.org> <GitHub@ResonatorSoft.org>
+Brendan Byrd <perl@resonatorsoft.org> <Perl@ResonatorSoft.org>
Brian Phillips <bphillips@cpan.org> <bphillips@digitalriver.com>
+Christian Walde <walde.christian@gmail.com> <walde.christian@googlemail.com>
+Jess Robinson <castaway@desert-island.me.uk><no-email-available@dev.catalystframework.org>
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org><ilmari.mannsaker@net-a-porter.com>
David Kamholz <dkamholz@cpan.org> <davekam@pobox.com>
David Schmidt <mail@davidschmidt.at> <d.schmidt@tripwolf.com>
David Schmidt <mail@davidschmidt.at> <dt@univie.ac.at>
David Schmidt <mail@davidschmidt.at> <davewood@gmx.at>
Devin Austin <dhoss@cpan.org> <devin.austin@gmail.com>
+Duncan Garland <Duncan.Garland@motortrak.com> <duncan@duncan-laptop.(none)>
Felix Antonius Wilhelm Ostmann <sadrak@cpan.org> <ostmann@sadraksaemp.intern4.websuche.de>
+Fitz Elliott <fitz.elliott@gmail.com> <felliott@fiskur.org>
Gerda Shank <gshank@cpan.org> <gerda.shank@gmail.com>
Gianni Ceccarelli <dakkar@thenautilus.net> <gianni.ceccarelli@net-a-porter.com>
Gordon Irving <goraxe@cpan.org> <goraxe@goraxe.me.uk>
Hakim Cassimally <osfameron@cpan.org> <hakim@vm-participo.(none)>
+Henry Van Styn <vanstyn@cpan.org> <vanstyn@intellitree.com>
+Jason M. Mills <jmmills@cpan.org> <jmmills@cpan.org>
Jonathan Chu <milki@rescomp.berkeley.edu> <milki@rescomp.berkeley.edu>
+Jose Luis Martinez <jlmartinez@capside.com> <jlmartinez@capside.com>
+Kent Fredric <kentnl@cpan.org> <kentfredric@gmail.com>
Matt Phillips <mattp@cpan.org> <mphillips@oanda.com>
Norbert Csongrádi <bert@cpan.org> <bert@cpan.org>
-Roman Filippov <romanf@cpan.org> <moltar@moltar.net>
Peter Rabbitson <ribasushi@cpan.org> <rabbit@viator.rabbit.us>
-Tim Bunce <Tim.Bunce@pobox.com> <Tim.Bunce@ig.co.uk>
+Roman Filippov <romanf@cpan.org> <moltar@moltar.net>
+Ronald J Kimball <rjk@tamias.net> <rkimball@pangeamedia.com>
+Samuel Kaufman <sam@socialflow.com> <sam@socialflow.com>
+Tim Bunce <tim.bunce@pobox.com> <Tim.Bunce@ig.co.uk>
Toby Corkindale <tjc@cpan.org> <toby@dryft.net>
+Tommy Butler <tbutler.cpan.org@internetalias.net> <tommybutler@users.noreply.github.com>
+Ton Voon <ton.voon@opsview.com> <ton.voon@opsera.com>
Wallace Reis <wreis@cpan.org> <wallace@reis.org.br>
#
# * Minimum perl officially supported by DBIC is 5.8.3. This *includes* the
# basic depchain. On failure either attempt to fix it or bring it to the
-# attention of ribasushi. *DO NOT* disable 5.8 testing - it is here for a
-# reason
-#
-# * The matrix is built from two main modes - CLEANTEST = [true|false].
-# - In the first case we test with minimal deps available, and skip everything
-# listed in DBIC::OptDesps. The modules are installed with classic CPAN
-# invocations and are *fully tested*. In other words we simulate what would
-# happen if a user tried to install on a just-compiled virgin perl
-# - Without CLEANTEST we bring the armada of RDBMS and install the maximum
-# 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 testing of dependencies under CLEANTEST runs single-threaded, at least
-# until we fix our entire dep-chain to safely pass under -j
-#
-# * The way .travis.yml is fed to the command controller is idiotic - it
-# makes using multiline `bash -c` statements impossible. Therefore to
-# aid readability (our travis logic is rather complex), the bulk of
-# functionality is moved to scripts. More about the problem (and the
-# WONTFIX "explanation") here: https://github.com/travis-ci/travis-ci/issues/497
+# attention of the maintainer. *DO NOT* disable 5.8 testing - it is here for
+# a very good reason
#
+# the entire run times out after 50 minutes, or after 5 minutes without
+# console output
#
# Smoke all branches except for blocked* and wip/*
-#
-# Additionally master does not smoke with bleadperl
-# ( implemented in maint/travis-ci_scripts/10_before_install.bash )
-#
branches:
except:
- /^wip\//
email:
recipients:
- ribasushi@cpan.org
- # Temporary - if it proves to be too noisy, we'll shut it off
- #- dbix-class-devel@lists.scsys.co.uk
on_success: change
on_failure: always
-# FIXME - This stuff is not yet available for free OSS accounts, sadpanda
-# First paragrah on http://about.travis-ci.org/docs/user/caching/
-#cache:
-# apt: true
-# directories:
-# - /var/cache/apt/archives
+addons:
+ apt:
+ packages:
+ - libapp-nopaste-perl
+ - net-tools
+# This is probably a net-loss for setup etc - a bare 'C' will likely fare much better
language: perl
-perl:
- - "5.18"
+# Currently not trying osx: https://github.com/travis-ci/travis-ci/issues/2314
+os: linux
-env:
- - CLEANTEST=false
- - CLEANTEST=true
+# The defaults run under the more rapid container infra. The hardware is
+# actually *much* slower, but the jobs start much faster, for more info see
+# https://docs.travis-ci.com/user/ci-environment/#Virtualization-environments
+# Combined with 'fast_finish' this will result in an "uh-oh" email as early
+# as possible
+dist: precise
+sudo: false
+env: CLEANTEST=true
+
+perl:
+ - "5.8"
+ - "5.10"
+ - "5.22-extras"
matrix:
+ fast_finish: true
+
include:
- # this particular perl is quite widespread
- - perl: 5.8.8_thr_mb
+
+ # Same as the "master matrix" above, frozen under older dist/infrastructure
+ # In genereal it is strongly recommended to keep things on the older
+ # version indefinitely - there is little value in-depth smoking on
+ # more recent software stacks
+ - perl: "5.8"
+ sudo: required
+ dist: precise
env:
- - CLEANTEST=true
- - BREWOPTS="-Duseithreads -Dusemorebits"
- - BREWVER=5.8.8
+ - CLEANTEST=false
- # so is this one (test a sane CPAN.pm)
- - perl: 5.12.4_thr_mb
+ - perl: "5.10"
+ sudo: required
+ dist: precise
env:
- - CLEANTEST=true
- - BREWOPTS="-Duseithreads -Dusemorebits"
- - BREWVER=5.12.4
+ - CLEANTEST=false
- # this is the perl suse ships
- - perl: 5.10.0_thr_dbg
+ - perl: "5.22-extras"
+ sudo: required
+ dist: precise
env:
- - CLEANTEST=true
- - BREWOPTS="-DDEBUGGING -Duseithreads"
- - BREWVER=5.10.0
+ - CLEANTEST=false
- # CLEANTEST of minimum supported
- - perl: 5.8.3_nt_mb
+ # CLEANTEST of minimum supported with non-tracing poisoning, single thread (hence the sudo)
+ - perl: "5.8.3_nt_mb"
+ sudo: required
+ dist: precise
env:
+ - VCPU_USE=1
- CLEANTEST=true
+ - POISON_ENV=true
+ - DBIC_TRACE_PROFILE=console_monochrome
+ - BREWVER=5.8.3
- BREWOPTS="-Dusemorebits"
+
+ # Full Test of minimum supported without threads with plain poisoned trace
+ - perl: "5.8.3_nt"
+ sudo: required
+ dist: precise
+ # run these under legacy - great simulation of low memory env
+ group: legacy
+ env:
+ - CLEANTEST=false
+ - POISON_ENV=true
+ - DBIC_TRACE=1
- BREWVER=5.8.3
- # Full Test of minimum supported with threads
- - perl: 5.8.5_thr
+ # Full Test of minimum supported with threads with non-tracing poisoning
+ - perl: "5.8.5_thr"
+ sudo: required
+ dist: precise
+ # run these under legacy - great simulation of low memory env
+ group: legacy
env:
- CLEANTEST=false
- - BREWOPTS="-Duseithreads"
+ - POISON_ENV=true
+ - DBIC_TRACE_PROFILE=console
- BREWVER=5.8.5
+ - BREWOPTS="-Duseithreads"
+
+ # CLEANTEST of solaris-like perl with non-tracing poisoning
+ - perl: "5.8.4_nt"
+ sudo: false
+ dist: precise
+ env:
+ - CLEANTEST=true
+ - POISON_ENV=true
- DBIC_TRACE_PROFILE=console
+ - BREWVER=5.8.4
- # Full Test of minimum supported without threads
- - perl: 5.8.3_nt
+ # Full test: this particular perl is quite widespread, single thread
+ - perl: "5.8.8_thr"
+ sudo: required
+ dist: precise
env:
+ - VCPU_USE=1
- CLEANTEST=false
- - BREWOPTS=""
- - BREWVER=5.8.3
- - DBIC_TRACE_PROFILE=console_monochrome
-
- ###
- # some permutations of tracing and envvar poisoning
+ - BREWVER=5.8.8
+ - BREWOPTS="-Duseithreads"
- - perl: 5.16.2_thr_mb
+ # CLEANTEST: this is the perl suse ships, with env poisoning
+ - perl: "5.10.0_thr_dbg"
+ sudo: false
+ dist: precise
env:
- - CLEANTEST=false
+ - CLEANTEST=true
- POISON_ENV=true
- - DBIC_TRACE=1
- - DBIC_MULTICREATE_DEBUG=0
+ - BREWVER=5.10.0
+ - BREWOPTS="-DDEBUGGING -Duseithreads"
+
+ # CLEANTEST: this one is in a number of debian-based LTS (test a sane CPAN.pm, single thread)
+ - perl: "5.14.2_thr_mb"
+ sudo: required
+ dist: precise
+ env:
+ - VCPU_USE=1
+ - CLEANTEST=true
+ - BREWVER=5.14.2
- BREWOPTS="-Duseithreads -Dusemorebits"
- - BREWVER=5.16.2
- - perl: 5.18
+ ###
+ # some permutations of tracing and envvar poisoning
+
+ - perl: "5.12.3_thr"
+ sudo: false
+ dist: precise
env:
- - CLEANTEST=false
+ - CLEANTEST=true
- POISON_ENV=true
+ - DBIC_TRACE=1
+ - 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"
+ sudo: required
+ dist: precise
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"
+ sudo: required
+ # explicit new infra spec preparing for a future forced upgrade
+ dist: trusty
env:
- CLEANTEST=false
- POISON_ENV=true
- DBIC_TRACE=1
- DBIC_TRACE_PROFILE=console_monochrome
- - DBIC_MULTICREATE_DEBUG=0
+ - DBICTEST_VIA_REPLICATED=0
+ - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1
###
# 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"
+ sudo: false
+ dist: precise
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 and plain trace
+ - perl: "devcpan_5.8.1"
+ sudo: false
+ dist: precise
env:
- CLEANTEST=true
- - BREWOPTS="-Duseithreads -Dusemorebits"
- - BREWVER=5.10.0
- DEVREL_DEPS=true
+ - POISON_ENV=true
+ - DBIC_TRACE=1
+ - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1
+ - BREWVER=5.8.1
+
+ # 5.8.3 with blead CPAN
+ - perl: "devcpan_5.8.3_mb"
+ sudo: required
+ # explicit new infra spec preparing for a future forced upgrade
+ dist: trusty
+ 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"
+ sudo: false
+ dist: precise
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"
+ sudo: false
+ dist: precise
+ env:
+ - CLEANTEST=true
+ - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1
- 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"
+ sudo: false
+ dist: precise
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"
+ sudo: false
+ dist: precise
+ env:
+ - CLEANTEST=true
- DEVREL_DEPS=true
+ - BREWVER=5.12.1
+ - BREWOPTS="-Duseithreads"
- # bleadperl with stock CPAN, full depchain test
- - perl: bleadperl
+ # bleadperl with stock CPAN, full depchain test with non-tracing poisoning, single thread
+ - perl: "bleadperl"
+ sudo: required
+ dist: precise
env:
+ - VCPU_USE=1
- CLEANTEST=true
+ - POISON_ENV=true
- BREWVER=blead
- # bleadperl with blead CPAN
- - perl: devcpan_bleadperl_thr_mb
+ # bleadperl with blead CPAN, single thread
+ - perl: "devcpan_bleadperl_thr_mb"
+ sudo: required
+ # explicitly do not specify dist - see what the default does
env:
+ - VCPU_USE=1
- 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"
+ sudo: false
+ dist: precise
+ 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
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
--- /dev/null
+#
+# 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) (<email>)
+#
+#
+# *** 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 <abraxxa@cpan.org>
+acca: Alexander Kuznetsov <acca@cpan.org>
+aherzog: Adam Herzog <adam@herzogdesigns.com>
+Alexander Keusch <cpan@keusch.at>
+alexrj: Alessandro Ranellucci <aar@cpan.org>
+alnewkirk: Al Newkirk <github@alnewkirk.com>
+Altreus: Alastair McGowan-Douglas <alastair.mcgowan@opusvl.com>
+amiri: Amiri Barksdale <amiribarksdale@gmail.com>
+amoore: Andrew Moore <amoore@cpan.org>
+Andrew Mehta <Andrew@unitedgames.co.uk>
+andrewalker: Andre Walker <andre@andrewalker.net>
+andybev: Andrew Beverley <a.beverley@ctrlo.com>
+andyg: Andy Grundman <andy@hybridized.org>
+ank: Andres Kievsky <ank@ank.com.ar>
+arc: Aaron Crane <arc@cpan.org>
+arcanez: Justin Hunter <justin.d.hunter@gmail.com>
+ash: Ash Berlin <ash@cpan.org>
+bert: Norbert Csongrádi <bert@cpan.org>
+bfwg: Colin Newell <colin.newell@gmail.com>
+blblack: Brandon L. Black <blblack@gmail.com>
+bluefeet: Aran Deltac <bluefeet@cpan.org>
+boghead: Bryan Beeley <cpan@beeley.org>
+bphillips: Brian Phillips <bphillips@cpan.org>
+brd: Brad Davis <brd@FreeBSD.org>
+Brian Kirkbride <brian.kirkbride@deeperbydesign.com>
+bricas: Brian Cassidy <bricas@cpan.org>
+brunov: Bruno Vecchi <vecchi.b@gmail.com>
+caelum: Rafael Kitover <rkitover@cpan.org>
+caldrin: Maik Hentsche <maik.hentsche@amd.com>
+castaway: Jess Robinson <castaway@desert-island.me.uk>
+chorny: Alexandr Ciornii <alexchorny@gmail.com>
+cj: C.J. Adams-Collier <cjcollier@cpan.org>
+claco: Christopher H. Laco <claco@cpan.org>
+clkao: CL Kao <clkao@clkao.org>
+Ctrl-O http://ctrlo.com/
+da5id: David Jack Olrik <david@olrik.dk>
+dams: Damien Krotkine <dams@cpan.org>
+dandv: Dan Dascalescu <ddascalescu+github@gmail.com>
+dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk>
+davewood: David Schmidt <mail@davidschmidt.at>
+daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>
+dduncan: Darren Duncan <darren@darrenduncan.net>
+debolaz: Anders Nor Berle <berle@cpan.org>
+dew: Dan Thomas <dan@godders.org>
+dim0xff: Dmitry Latin <dim0xff@gmail.com>
+dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
+dnm: Justin Wheeler <jwheeler@datademons.com>
+dpetrov: Dimitar Petrov <mitakaa@gmail.com>
+Dr^ZigMan: Robert Stone <drzigman@drzigman.com>
+dsteinbrunner: David Steinbrunner <dsteinbrunner@pobox.com>
+duncan_dmg: Duncan Garland <Duncan.Garland@motortrak.com>
+dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
+dyfrgi: Michael Leuchtenburg <michael@slashhome.org>
+edenc: Eden Cardim <edencardim@gmail.com>
+Eligo http://eligo.co.uk/
+ether: Karen Etheridge <ether@cpan.org>
+evdb: Edmund von der Burg <evdb@ecclestoad.co.uk>
+faxm0dem: Fabien Wernli <cpan@faxm0dem.org>
+felliott: Fitz Elliott <fitz.elliott@gmail.com>
+freetime: Bill Moseley <moseley@hank.org>
+frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
+gbjk: Gareth Kirwan <gbjk@thermeon.com>
+geotheve: Georgina Thevenet <geotheve@gmail.com>
+Getty: Torsten Raudssus <torsten@raudss.us>
+goraxe: Gordon Irving <goraxe@cpan.org>
+gphat: Cory G Watson <gphat@cpan.org>
+Grant Street Group http://www.grantstreet.com/
+gregoa: Gregor Herrmann <gregoa@debian.org>
+groditi: Guillermo Roditi <groditi@cpan.org>
+gshank: Gerda Shank <gshank@cpan.org>
+guacamole: Fred Steinberg <fred.steinberg@gmail.com>
+Haarg: Graham Knop <haarg@haarg.org>
+hobbs: Andrew Rodland <andrew@cleverdomain.org>
+Ian Wells <ijw@cack.org.uk>
+idn: Ian Norton <i.norton@shadowcat.co.uk>
+ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+ingy: Ingy döt Net <ingy@ingy.net>
+initself: Mike Baas <mike@initselftech.com>
+ironcamel: Naveed Massjouni <naveedm9@gmail.com>
+jasonmay: Jason May <jason.a.may@gmail.com>
+jawnsy: Jonathan Yu <jawnsy@cpan.org>
+jegade: Jens Gassmann <jens.gassmann@atomix.de>
+jeneric: Eric A. Miller <emiller@cpan.org>
+jesper: Jesper Krogh <jesper@krogh.cc>
+Jesse Sheidlower <jester@panix.com>
+jgoulah: John Goulah <jgoulah@cpan.org>
+jguenther: Justin Guenther <jguenther@cpan.org>
+jhannah: Jay Hannah <jay@jays.net>
+jmac: Jason McIntosh <jmac@appleseed-sc.com>
+jmmills: Jason M. Mills <jmmills@cpan.org>
+jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com>
+Joe Carlson <jwcarlson@lbl.gov>
+jon: Jon Schutz <jjschutz@cpan.org>
+Jordan Metzmeier <jmetzmeier@magazines.com>
+jshirley: J. Shirley <jshirley@gmail.com>
+kaare: Kaare Rasmussen
+kd: Kieren Diment <diment@gmail.com>
+kentnl: Kent Fredric <kentnl@cpan.org>
+kkane: Kevin L. Kane <kevin.kane@gmail.com>
+konobi: Scott McWhirter <konobi@cpan.org>
+lamoz: Konstantin A. Pustovalov <konstantin.pustovalov@gmail.com>
+Lasse Makholm <lasse@unity3d.com>
+lejeunerenard: Sean Zellmer <sean@lejeunerenard.com>
+littlesavage: Alexey Illarionov <littlesavage@orionet.ru>
+lukes: Luke Saunders <luke.saunders@gmail.com>
+marcus: Marcus Ramberg <mramberg@cpan.org>
+mateu: Mateu X. Hunter <hunter@missoula.org>
+Matt LeBlanc <antirice@gmail.com>
+Matt Sickler <imMute@msk4.com>
+mattlaw: Matt Lawrence
+mattp: Matt Phillips <mattp@cpan.org>
+mdk: Mark Keating <m.keating@shadowcat.co.uk>
+melo: Pedro Melo <melo@simplicidade.org>
+metaperl: Terrence Brannon <metaperl@gmail.com>
+michaelr: Michael Reddick <michael.reddick@gmail.com>
+milki: Jonathan Chu <milki@rescomp.berkeley.edu>
+minty: Murray Walker <perl@minty.org>
+mithaldu: Christian Walde <walde.christian@gmail.com>
+mjemmeson: Michael Jemmeson <michael.jemmeson@gmail.com>
+mna: Maya
+mo: Moritz Onken <onken@netcubed.de>
+moltar: Roman Filippov <romanf@cpan.org>
+moritz: Moritz Lenz <moritz@faui2k3.org>
+mrf: Mike Francis <ungrim97@gmail.com>
+mst: Matt S. Trout <mst@shadowcat.co.uk>
+mstratman: Mark A. Stratman <stratman@gmail.com>
+ned: Neil de Carteret <n3dst4@gmail.com>
+nigel: Nigel Metheringham <nigelm@cpan.org>
+ningu: David Kamholz <dkamholz@cpan.org>
+Nniuq: Ron "Quinn" Straight" <quinnfazigu@gmail.org>
+norbi: Norbert Buchmuller <norbi@nix.hu>
+nothingmuch: Yuval Kogman <nothingmuch@woobling.org>
+nuba: Nuba Princigalli <nuba@cpan.org>
+Numa: Dan Sully <daniel@cpan.org>
+oalders: Olaf Alders <olaf@wundersolutions.com>
+Olly Betts <olly@survex.com>
+osfameron: Hakim Cassimally <osfameron@cpan.org>
+ovid: Curtis "Ovid" Poe <ovid@cpan.org>
+oyse: Øystein Torget <oystein.torget@dnv.com>
+paulm: Paul Makepeace <paulm+pause@paulm.com>
+penguin: K J Cheetham <jamie@shadowcatsystems.co.uk>
+perigrin: Chris Prather <chris@prather.org>
+Peter Siklósi <einon@einon.hu>
+Peter Valdemar Mørch <peter@morch.com>
+peter: Peter Collingbourne <peter@pcc.me.uk>
+phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
+plu: Johannes Plunien <plu@cpan.org>
+Possum: Daniel LeWarne <possum@cpan.org>
+pplu: Jose Luis Martinez <jlmartinez@capside.com>
+quicksilver: Jules Bean <jules@jellybean.co.uk>
+racke: Stefan Hornburg <racke@linuxia.de>
+rafl: Florian Ragwitz <rafl@debian.org>
+rainboxx: Matthias Dietrich <perl@rb.ly>
+rbo: Robert Bohne <rbo@cpan.org>
+rbuels: Robert Buels <rmb32@cornell.edu>
+rdj: Ryan D Johnson <ryan@innerfence.com>
+Relequestual: Ben Hutton <relequestual@gmail.com>
+renormalist: Steffen Schwigon <schwigon@cpan.org>
+ribasushi: Peter Rabbitson <ribasushi@cpan.org>
+rjbs: Ricardo Signes <rjbs@cpan.org>
+Robert Krimen <rkrimen@cpan.org>
+Robert Olson <bob@rdolson.org>
+robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Roman Ardern-Corris <spam_in@3legs.com>
+ruoso: Daniel Ruoso <daniel@ruoso.com>
+Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
+sc_: Just Another Perl Hacker
+schwern: Michael G Schwern <mschwern@cpan.org>
+Scott R. Godin <webdragon.net@gmail.com>
+scotty: Scotty Allen <scotty@scottyallen.com>
+semifor: Marc Mims <marc@questright.com>
+Simon Elliott <cpan@browsing.co.uk>
+SineSwiper: Brendan Byrd <perl@resonatorsoft.org>
+skaufman: Samuel Kaufman <sam@socialflow.com>
+solomon: Jared Johnson <jaredj@nmgi.com>
+spb: Stephen Bennett <stephen@freenode.net>
+Squeeks <squeek@cpan.org>
+srezic: Slaven Rezic <slaven@rezic.de>
+sszabo: Stephan Szabo <sszabo@bigpanda.com>
+Stephen Peters <steve@stephenpeters.me>
+stonecolddevin: Devin Austin <dhoss@cpan.org>
+talexb: Alex Beamish <talexb@gmail.com>
+tamias: Ronald J Kimball <rjk@tamias.net>
+TBSliver: Tom Bloor <t.bloor@shadowcat.co.uk>
+teejay: Aaron Trevena <teejay@cpan.org>
+theorbtwo: James Mastros <james@mastros.biz>
+Thomas Kratz <tomk@cpan.org>
+timbunce: Tim Bunce <tim.bunce@pobox.com>
+tinita: Tina Mueller <cpan2@tinita.de>
+Todd Lipcon
+Tom Hukins <tom@eborcom.com>
+tommy: Tommy Butler <tbutler.cpan.org@internetalias.net>
+tonvoon: Ton Voon <ton.voon@opsview.com>
+triode: Pete Gamache <gamache@cpan.org>
+typester: Daisuke Murase <typester@cpan.org>
+uree: Oriol Soriano <oriol.soriano@capside.com>
+uwe: Uwe Voelker <uwe@uwevoelker.de>
+Vadim Pushtaev <pushtaev.vm@gmail.com>
+vanstyn: Henry Van Styn <vanstyn@cpan.org>
+victori: Victor Igumnov <victori@cpan.org>
+wdh: Will Hawes <wdhawes@gmail.com>
+wesm: Wes Malone <wes@mitsi.com>
+willert: Sebastian Willert <willert@cpan.org>
+wintermute: Toby Corkindale <tjc@cpan.org>
+wreis: Wallace Reis <wreis@cpan.org>
+xenoterracide: Caleb Cushing <xenoterracide@gmail.com>
+xmikew: Mike Wisener <xmikew@32ths.com>
+yrlnry: Mark Jason Dominus <mjd@plover.com>
+zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
+Zefram: Andrew Main <zefram@fysh.org>
+Zoffix: Zoffix Znet <cpan@zoffix.com>
Revision history for DBIx::Class
+ * Notable Changes and Deprecations
+ - Neither exception_action() nor $SIG{__DIE__} handlers are invoked
+ on recoverable errors. This ensures that the retry logic is fully
+ insulated from changes in control flow, as the handlers are only
+ invoked when an error is leaving the DBIC internals to be handled by
+ the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125)
+ - $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
+ - When using non-scalars (e.g. arrays) as literal bind values it is no
+ longer necessary to explicitly specify a bindtype (this turned out
+ to be a mostly useless overprotection)
+ - 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
+ - Fix incorrect SQL generated with invalid {rows} on complex resultset
+ operations, generally more robust handling of rows/offset attrs
+ - Fix incorrect $storage state on unexpected RDBMS disconnects and
+ other failure events, preventing clean reconnection (RT#110429)
+ - Ensure leaving an exception stack via Return::MultiLevel or something
+ similar produces a large warning
+ - 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 spurious ROLLBACK statements when a TxnScopeGuard fails a commit
+ of a transaction with deferred FK checks: a guard is now inactivated
+ immediately before the commit is attempted (RT#107159)
+ - Work around unreliable $sth->finish() on INSERT ... RETURNING within
+ DBD::Firebird on some compiler/driver combinations (RT#110979)
+ - Fix several corner cases with Many2Many over custom relationships
+ - Fix the Sybase ASE storage incorrectly attempting to retrieve an
+ autoinc value when inserting rows containing blobs (GH#82)
+
+ * Misc
+ - Fix invalid variable names in ResultSource::View examples
+ - Typo fixes from downstream debian packagers (RT#112007)
+ - 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
+ - Config::Any is no longer a core dep, but instead is migrated to a new
+ optdep group 'config_file_reader'
+
+0.082821 2016-02-11 17:58 (UTC)
+ * Fixes
+ - 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 test failures when DBICTEST_SYBASE_DSN is set (unnoticed change
+ in error message wording during 0.082800 and a bogus test)
+ - Remove largely obsolete test of SQLite view deployment (RT#111916)
+
+ * Misc
+ - Work around rare test deadlock under heavy parallelism (RT#108390)
+
+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
- - Avoid unnecessary database hits when accessing prefetched related
- resultsets with no rows.
+ - 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
--- /dev/null
+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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 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 ---
+
+
-^(?!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
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)
$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
'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',
'Context::Preserve' => '0.01',
'Data::Dumper::Concise' => '2.020',
'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
'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');
+tests_recursive ('xt') if (
+ $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} )
+);
+
+install_script (qw|
+ script/dbicadmin
+|);
+
# this is so we can order requires alphabetically
# copies are needed for potential author requires injection
my $reqs = {
# 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;
--- /dev/null
+### 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
--- /dev/null
+### 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
--- /dev/null
+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)) },
+ })
+}
__PACKAGE__->add_unique_constraint([qw( name )]);
-__PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd');
+__PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd', 'artistid');
1;
data_type => 'integer',
is_auto_increment => 1
},
- artist => {
+ artistid => {
data_type => 'integer',
},
title => {
__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;
data_type => 'integer',
is_auto_increment => 1
},
- cd => {
+ cdid => {
data_type => 'integer',
},
title => {
__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;
}
$schema->populate('Cd', [
- [qw/title artist/],
+ [qw/title artistid/],
@cds,
]);
}
$schema->populate('Track',[
- [qw/cd title/],
+ [qw/cdid title/],
@tracks,
]);
}
);
while (my $track = $rs->next) {
- print $track->title . "\n";
+ print $track->title . " (from the CD '" . $track->cd->title
+ . "')\n";
}
print "\n";
}
}
);
my $cd = $rs->first;
- print $cd->title . "\n\n";
+ print $cd->title . " has the track '$tracktitle'.\n\n";
}
sub get_cds_by_artist {
}
);
my $artist = $rs->first;
- print $artist->name . "\n\n";
+ print $artist->name . " recorded the track '$tracktitle'.\n\n";
}
sub get_artist_by_cd {
}
);
my $artist = $rs->first;
- print $artist->name . "\n\n";
+ print $artist->name . " recorded the CD '$cdtitle'.\n\n";
}
# $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
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
+#
+# The oddball BEGIN is there for... reason unknown
+# It does make non-segfaulty difference on pre-5.8.5 perls, so shrug
+BEGIN {
+ sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor };
+}
sub mk_classdata {
shift->mk_classaccessor(@_);
};
}
+# *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.
recommended to read (at the very least) the
L<Manuals|DBIx::Class::Manual::DocMap/Manuals> 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
my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ...
my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query
- # new() makes a Result object but doesnt insert it into the DB.
+ # new() makes a Result object but doesn't insert it into the DB.
# create() is the same as new() then insert().
my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' });
$new_cd->artist($cd->artist);
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<contact|/GETTING HELP/SUPPORT> either of the L</CAT HERDERS> 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 ;)
=item * Travis-CI log: L<https://travis-ci.org/dbsrgits/dbix-class/builds>
=for html
-↪ Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
+↪ Bleeding edge dev CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
=back
-=head1 AUTHOR
-
-mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
-
-(I mostly consider myself "project founder" these days but the AUTHOR heading
-is traditional :)
-
-=head1 CONTRIBUTORS
-
-abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
-
-acca: Alexander Kuznetsov <acca@cpan.org>
-
-aherzog: Adam Herzog <adam@herzogdesigns.com>
-
-Alexander Keusch <cpan@keusch.at>
-
-alexrj: Alessandro Ranellucci <aar@cpan.org>
-
-alnewkirk: Al Newkirk <we@ana.im>
-
-amiri: Amiri Barksdale <amiri@metalabel.com>
-
-amoore: Andrew Moore <amoore@cpan.org>
-
-andrewalker: Andre Walker <andre@andrewalker.net>
-
-andyg: Andy Grundman <andy@hybridized.org>
-
-ank: Andres Kievsky
-
-arc: Aaron Crane <arc@cpan.org>
-
-arcanez: Justin Hunter <justin.d.hunter@gmail.com>
-
-ash: Ash Berlin <ash@cpan.org>
-
-bert: Norbert Csongrádi <bert@cpan.org>
-
-blblack: Brandon L. Black <blblack@gmail.com>
-
-bluefeet: Aran Deltac <bluefeet@cpan.org>
-
-bphillips: Brian Phillips <bphillips@cpan.org>
-
-boghead: Bryan Beeley <cpan@beeley.org>
-
-brd: Brad Davis <brd@FreeBSD.org>
-
-bricas: Brian Cassidy <bricas@cpan.org>
-
-brunov: Bruno Vecchi <vecchi.b@gmail.com>
-
-caelum: Rafael Kitover <rkitover@cpan.org>
-
-caldrin: Maik Hentsche <maik.hentsche@amd.com>
-
-castaway: Jess Robinson
-
-claco: Christopher H. Laco
-
-clkao: CL Kao
-
-da5id: David Jack Olrik <djo@cpan.org>
-
-dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk>
-
-davewood: David Schmidt <davewood@gmx.at>
-
-daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>
-
-debolaz: Anders Nor Berle <berle@cpan.org>
-
-dew: Dan Thomas <dan@godders.org>
-
-dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
-
-dnm: Justin Wheeler <jwheeler@datademons.com>
-
-dpetrov: Dimitar Petrov <mitakaa@gmail.com>
-
-dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
-
-dyfrgi: Michael Leuchtenburg <michael@slashhome.org>
-
-edenc: Eden Cardim <edencardim@gmail.com>
-
-ether: Karen Etheridge <ether@cpan.org>
-
-felliott: Fitz Elliott <fitz.elliott@gmail.com>
-
-freetime: Bill Moseley <moseley@hank.org>
-
-frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
-
-goraxe: Gordon Irving <goraxe@cpan.org>
-
-gphat: Cory G Watson <gphat@cpan.org>
-
-Grant Street Group L<http://www.grantstreet.com/>
-
-groditi: Guillermo Roditi <groditi@cpan.org>
-
-Haarg: Graham Knop <haarg@haarg.org>
-
-hobbs: Andrew Rodland <arodland@cpan.org>
-
-ilmari: Dagfinn Ilmari MannsE<aring>ker <ilmari@ilmari.org>
-
-initself: Mike Baas <mike@initselftech.com>
-
-ironcamel: Naveed Massjouni <naveedm9@gmail.com>
-
-jawnsy: Jonathan Yu <jawnsy@cpan.org>
-
-jasonmay: Jason May <jason.a.may@gmail.com>
-
-jesper: Jesper Krogh
-
-jgoulah: John Goulah <jgoulah@cpan.org>
-
-jguenther: Justin Guenther <jguenther@cpan.org>
+=head1 AUTHORS
-jhannah: Jay Hannah <jay@jays.net>
+Even though a large portion of the source I<appears> 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<CPAN|http://cpan.org>.
+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 <jmac@appleseed-sc.com>
+=for comment this line is replaced with the author list at dist-building time
-jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com>
+The canonical source of authors and their details is the F<AUTHORS> file at
+the root of this distribution (or repository). The canonical source of
+per-line authorship is the L<git repository|/HOW TO CONTRIBUTE> history
+itself.
-jon: Jon Schutz <jjschutz@cpan.org>
+=head1 CAT HERDERS
-jshirley: J. Shirley <jshirley@gmail.com>
+The fine folks nudging the project in a particular direction:
-kaare: Kaare Rasmussen
-
-konobi: Scott McWhirter
-
-littlesavage: Alexey Illarionov <littlesavage@orionet.ru>
-
-lukes: Luke Saunders <luke.saunders@gmail.com>
-
-marcus: Marcus Ramberg <mramberg@cpan.org>
-
-mattlaw: Matt Lawrence
-
-mattp: Matt Phillips <mattp@cpan.org>
-
-michaelr: Michael Reddick <michael.reddick@gmail.com>
-
-milki: Jonathan Chu <milki@rescomp.berkeley.edu>
-
-mithaldu: Christian Walde <walde.christian@gmail.com>
-
-mjemmeson: Michael Jemmeson <michael.jemmeson@gmail.com>
-
-mstratman: Mark A. Stratman <stratman@gmail.com>
-
-ned: Neil de Carteret
-
-nigel: Nigel Metheringham <nigelm@cpan.org>
-
-ningu: David Kamholz <dkamholz@cpan.org>
-
-Nniuq: Ron "Quinn" Straight" <quinnfazigu@gmail.org>
-
-norbi: Norbert Buchmuller <norbi@nix.hu>
-
-nuba: Nuba Princigalli <nuba@cpan.org>
-
-Numa: Dan Sully <daniel@cpan.org>
-
-ovid: Curtis "Ovid" Poe <ovid@cpan.org>
-
-oyse: E<Oslash>ystein Torget <oystein.torget@dnv.com>
-
-paulm: Paul Makepeace
-
-penguin: K J Cheetham
-
-perigrin: Chris Prather <chris@prather.org>
-
-peter: Peter Collingbourne <peter@pcc.me.uk>
-
-Peter Siklósi <einon@einon.hu>
-
-Peter Valdemar ME<oslash>rch <peter@morch.com>
-
-phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
-
-plu: Johannes Plunien <plu@cpan.org>
-
-Possum: Daniel LeWarne <possum@cpan.org>
-
-quicksilver: Jules Bean
-
-rafl: Florian Ragwitz <rafl@debian.org>
-
-rainboxx: Matthias Dietrich <perl@rb.ly>
-
-rbo: Robert Bohne <rbo@cpan.org>
-
-rbuels: Robert Buels <rmb32@cornell.edu>
-
-rdj: Ryan D Johnson <ryan@innerfence.com>
-
-ribasushi: Peter Rabbitson <ribasushi@cpan.org>
-
-rjbs: Ricardo Signes <rjbs@cpan.org>
-
-robkinyon: Rob Kinyon <rkinyon@cpan.org>
-
-Robert Olson <bob@rdolson.org>
-
-moltar: Roman Filippov <romanf@cpan.org>
-
-Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
-
-sc_: Just Another Perl Hacker
-
-scotty: Scotty Allen <scotty@scottyallen.com>
-
-semifor: Marc Mims <marc@questright.com>
-
-SineSwiper: Brendan Byrd <bbyrd@cpan.org>
-
-solomon: Jared Johnson <jaredj@nmgi.com>
-
-spb: Stephen Bennett <stephen@freenode.net>
-
-Squeeks <squeek@cpan.org>
-
-sszabo: Stephan Szabo <sszabo@bigpanda.com>
-
-talexb: Alex Beamish <talexb@gmail.com>
-
-tamias: Ronald J Kimball <rjk@tamias.net>
-
-teejay : Aaron Trevena <teejay@cpan.org>
-
-Todd Lipcon
-
-Tom Hukins
-
-tonvoon: Ton Voon <tonvoon@cpan.org>
-
-triode: Pete Gamache <gamache@cpan.org>
-
-typester: Daisuke Murase <typester@cpan.org>
-
-victori: Victor Igumnov <victori@cpan.org>
-
-wdh: Will Hawes
-
-wesm: Wes Malone <wes@mitsi.com>
-
-willert: Sebastian Willert <willert@cpan.org>
-
-wreis: Wallace Reis <wreis@cpan.org>
-
-xenoterracide: Caleb Cushing <xenoterracide@gmail.com>
+=over
-yrlnry: Mark Jason Dominus <mjd@plover.com>
+B<ribasushi>: Peter Rabbitson <ribasushi@cpan.org>
+(present day maintenance and controlled evolution)
-zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
+B<castaway>: Jess Robinson <castaway@desert-island.me.uk>
+(lions share of the reference documentation and manuals)
-Zefram: Andrew Main <zefram@fysh.org>
+B<mst>: Matt S Trout <mst@shadowcat.co.uk> (project founder -
+original idea, architecture and implementation)
-=head1 COPYRIGHT
+=back
-Copyright (c) 2005 - 2011 the DBIx::Class L</AUTHOR> and L</CONTRIBUTORS>
-as listed above.
+=head1 COPYRIGHT AND LICENSE
-=head1 LICENSE
+Copyright (c) 2005 by mst, castaway, ribasushi, and other DBIx::Class
+L</AUTHORS> as listed above and in F<AUTHORS>.
This library is free software and may be distributed under the same terms
-as perl itself.
+as perl5 itself. See F<LICENSE> for the complete licensing terms.
This class now exists in its own right on CPAN as Class::Accessor::Grouped
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
-
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);
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
sub _build_config {
my ($self) = @_;
- try { require Config::Any }
- catch { die ("Config::Any is required to parse the config file.\n") };
-
my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
# just grab the config from the config file
$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 );
}
$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);
}
return $cfg;
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
return join ("\n\n",
'=head1 AUTHORS',
- 'See L<DBIx::Class/CONTRIBUTORS>',
+ 'See L<DBIx::Class/AUTHORS>',
'=head1 LICENSE',
'You may distribute this code under the same terms as Perl itself',
'=cut',
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
Iterator
/);
- #DBIx::Class::ObjIndexStubs
1;
+__END__
+
=head1 NAME
DBIx::Class::CDBICompat - Class::DBI Compatibility layer.
=back
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> 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<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=cut
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return $class->resultset_instance->search($where, $attr);
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
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 {
use strict;
use warnings;
use Sub::Name ();
-use Storable 'dclone';
use List::Util ();
use base qw/DBIx::Class::Row/;
# 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);
: $obj->set_column($col => shift);
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
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__
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;
return $self->next::method({ $primary_columns[0] => $arg });
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
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 "
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;
}
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
}
}
return $table;
}
+=head1 FURTHER QUESTIONS?
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-package DBIx::Class::CDBICompat::Iterator::ResultSet;
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
+package # hide
+ DBIx::Class::CDBICompat::Iterator::ResultSet;
use strict;
use warnings;
sub clear_object_index {}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
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;
use strict;
use warnings;
-use Sub::Name ();
+
+use DBIx::Class::_Util 'quote_sub';
=head1 NAME
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<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
1;
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 Scalar::Util 'blessed';
+use DBIx::Class::_Util qw(quote_sub perlstring);
__PACKAGE__->mk_classdata('__meta_info' => {});
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'};
);
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;
}
-
}
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);
}
: undef());
if (ref $where eq 'HASH') {
foreach my $key (keys %$where) { # has_a deflation hack
- $where->{$key} = ''.$where->{$key}
- if eval { $where->{$key}->isa('DBIx::Class') };
+ $where->{$key} = ''.$where->{$key} if (
+ defined blessed $where->{$key}
+ and
+ $where->{$key}->isa('DBIx::Class')
+ );
}
}
$self->next::method($where, $attrs);
}
+sub new_related {
+ return shift->search_related(shift)->new_result(shift);
+}
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
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;
return 1;
}
-1;
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+=cut
+
+1;
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__$/ );
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
+ $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
#############################
) ? $f[3] : undef;
? "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: "
+ ),
);
};
1;
+__END__
+
=head1 NAME
DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
Like L</carp> but warns only once for the life of the perl interpreter
(regardless of callsite).
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
=cut
1;
+__END__
+
=head1 NAME
DBIx::Class::Core - Core set of DBIx::Class modules
A better overview of the methods found in a Result class can be found
in L<DBIx::Class::Manual::ResultClass>.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return @all;
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
=end hidden
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
This is meant for internal use by L<DBIx::Class>'s C<throw_exception>
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<Carp/confess>.
+Expects a scalar exception message. The optional boolean C<$stacktrace>
+causes it to output a full trace similar to L<confess|Carp/DESCRIPTION>.
DBIx::Class::Exception->throw('Foo');
try { ... } catch { DBIx::Class::Exception->throw(shift) }
# 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',
);
die shift;
}
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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);
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};
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};
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);
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 (@_);
}
$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});
}
}
1;
+__END__
+
=head1 NAME
DBIx::Class::FilterColumn - Automatically convert column data
In this case the C<filter_from_storage> is not required, as just
passing the database value through to perl does the right thing.
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use strict;
use warnings;
-use base qw/DBIx::Class::Row/;
+use base 'DBIx::Class::Row';
+use SQL::Abstract 'is_literal_value';
+use namespace::clean;
=head1 NAME
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);
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
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);
}
=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
=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
=back
-=head1 AUTHOR
-
-Matt S. Trout <mst@shadowcatsystems.co.uk>
-
-=head1 CONTRIBUTORS
-
-Daniel Westermann-Clark <danieltwc@cpan.org> (documentation)
+=head1 FURTHER QUESTIONS?
-Jess Robinson <cpan@desert-island.demon.co.uk>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
use warnings;
use base qw/DBIx::Class/;
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
a C<datetime> field the methods C<parse_datetime> and C<format_datetime>
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<DateTime::Format> for more information on
-date formatting.
+be used as a fallback. See L<DateTime/Formatters And Stringification>
+for more information on date formatting.
For more help with using components, see L<DBIx::Class::Manual::Component/USING>.
my $preferred_method = sprintf($method_fmt, $info->{ _ic_dt_method });
my $method = $parser->can($preferred_method) || sprintf($method_fmt, 'datetime');
- return try {
+ return dbic_internal_try {
$parser->$method($value);
}
catch {
=back
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 CONTRIBUTORS
-
-Aran Deltac <bluefeet@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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'
);
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
}
# 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});
}
sub _file_column_callback {}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Victor Igumnov
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
Existing components, and documentation and example on how to
develop new ones.
-=cut
+=head1 FURTHER QUESTIONS?
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
L<DBIx::Class::Manual::Cookbook>
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Aran Clary Deltac <bluefeet@cpan.org>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
);
... and you'll get back a perfect L<DBIx::Class::ResultSet> (except, of course,
-that you cannot modify the rows it contains, e.g. cannot call L</update>,
-L</delete>, ... on it).
+that you cannot modify the rows it contains, e.g. cannot call
+L<update|DBIx::Class::ResultSet/update> or
+L<delete|DBIx::Class::ResultSet/delete> on it).
Note that you cannot have bind parameters unless is_virtual is set to true.
=head2 Software Limits
When your RDBMS does not have a working SQL limit mechanism (e.g. Sybase ASE)
-and L<GenericSubQ|SQL::Abstract::Limit/GenericSubQ> is either too slow or does
-not work at all, you can try the
+and L<GenericSubQ|DBIx::Class::SQLMaker::LimitDialects/GenericSubQ> is either
+too slow or does not work at all, you can try the
L<software_limit|DBIx::Class::ResultSet/software_limit>
L<DBIx::Class::ResultSet> attribute, which skips over records to simulate limits
in the Perl layer.
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<set_cache|DBIx::Class::Resultset/set_cache> method:
+L<set_cache|DBIx::Class::ResultSet/set_cache> method:
my @uploadable_groups;
while (my $group = $groups->next) {
# Abort the whole job
if ($_ =~ /horrible_problem/) {
- print "something horrible happend, aborting job!";
+ print "something horrible happened, aborting job!";
die $_; # rethrow error
}
}
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<<txn_do>>: If
-the C<try>-block around C<txn_do> fails, a rollback is issued. If the C<try>
-succeeds, the transaction is committed (or the savepoint released).
+commits are happening, but it works just the same as for plain
+L<txn_do|DBIx::Class::Storage/txn_do>: If the L<try|Try::Tiny/try>-block
+around L<txn_do|DBIx::Class::Storage/txn_do> fails, a rollback is issued.
+If the L<try|Try::Tiny/try> succeeds, the transaction is committed
+(or the savepoint released).
While you can get more fine-grained control using C<svp_begin>, C<svp_release>
and C<svp_rollback>, it is strongly recommended to use C<txn_do> with coderefs.
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<DBIx::Class::ResultSet/search> family of
methods) you cannot directly use array references (since this is interpreted as
a list of values to be C<OR>ed), 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<SQL::Abstract/array_datatypes> and L<SQL::Abstract/Literal SQL with
+See L<SQL::Abstract/-value> and L<SQL::Abstract/Literal SQL with
placeholders and bind values (subqueries)> for more explanation. Note that
L<DBIx::Class> sets L<SQL::Abstract/bindtype> to C<columns>, so you must pass
the bind values (the C<[1, 2, 3]> arrayref in the above example) wrapped in
=head2 Formatting DateTime objects in queries
To ensure C<WHERE> conditions containing L<DateTime> arguments are properly
-formatted to be understood by your RDBMS, you must use the C<DateTime>
+formatted to be understood by your RDBMS, you must use the L<DateTime>
formatter returned by L<DBIx::Class::Storage::DBI/datetime_parser> to format
any L<DateTime> objects you pass to L<search|DBIx::Class::ResultSet/search>
conditions. Any L<Storage|DBIx::Class::Storage> object attached to your
-L<Schema|DBIx::Class::Schema> provides a correct C<DateTime> formatter, so
+L<Schema|DBIx::Class::Schema> provides a correct L<DateTime> formatter, so
all you have to do is:
my $dtf = $schema->storage->datetime_parser;
C<DateTime> object, which almost never matches the RDBMS expectations.
This kludge is necessary only for conditions passed to
-L<DBIx::Class::ResultSet/search>, whereas
-L<create|DBIx::Class::ResultSet/create>,
-L<find|DBIx::Class::ResultSet/find>,
-L<DBIx::Class::Row/update> (but not L<DBIx::Class::ResultSet/update>) are all
+L<search|DBIx::Class::ResultSet/search> and L<DBIx::Class::ResultSet/find>,
+whereas L<create|DBIx::Class::ResultSet/create> and
+L<DBIx::Class::Row/update> (but not L<DBIx::Class::ResultSet/update>) are
L<DBIx::Class::InflateColumn>-aware and will do the right thing when supplied
-an inflated C<DateTime> object.
+an inflated L<DateTime> object.
=head2 Using Unicode
=head3 Oracle
Information about Oracle support for unicode can be found in
-L<DBD::Oracle/Unicode>.
+L<DBD::Oracle/UNICODE>.
=head3 PostgreSQL
significant startup delay.
For production use a statically defined schema (which can be generated
-using L<DBIx::Class::Schema::Loader|DBIx::Class::Schema::Loader> to dump
-the database schema once - see
+using L<DBIx::Class::Schema::Loader> to dump the database schema once - see
L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> and
-L<dump_directory|DBIx::Class::Schema::Loader/dump_directory> for more
+L<dump_directory|DBIx::Class::Schema::Loader::Base/dump_directory> for more
details on creating static schemas from a database).
=head2 Move Common Startup into a Base Class
=head2 Cached statements
-L<DBIx::Class> 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<DBIx::Class> 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/CachedKids> hash:
# print all currently cached prepared statements
print for keys %{$schema->storage->dbh->{CachedKids}};
});
=cut
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=item L<DBIx::Class::InflateColumn> - Making objects out of your column values.
=back
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
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<examples/Schema/db/example.db>. 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 <unpacked-DBIC-tarball>/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 <unpacked-DBIC-tarball>/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<DBD::mysql>.
-
- 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<examples/Schema>.
-
-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<testdb.pl> 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<DBIx::Class::Schema/load_namespaces> to load in the
appropriate L<Result|DBIx::Class::Manual::ResultClass> classes from the
C<MyApp::Schema::Result> namespace, and any required
L<ResultSet|DBIx::Class::ResultSet> classes from the
-C<MyApp::Schema::ResultSet> namespace (although we created the directory
-in the directions above we did not add, or need to add, any resultset
-classes).
+C<MyApp::Schema::ResultSet> namespace (although we did not add, nor needed
+any such classes in this example).
+
+=head1 FURTHER QUESTIONS?
-=head1 TODO
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 AUTHOR
+=head1 COPYRIGHT AND LICENSE
- sc_ from irc.perl.org#dbix-class
- Kieren Diment <kd@totaldatasolution.com>
- Nigel Metheringham <nigelm@cpan.org>
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
=item .. store/retrieve Unicode data in my database?
-Make sure you database supports Unicode and set the connect
+Make sure your database supports Unicode and set the connect
attributes appropriately - see
L<DBIx::Class::Manual::Cookbook/Using Unicode>
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<DBIx::Class::ResultSource/table> call. Eg:
+L<table|DBIx::Class::ResultSourceProxy::Table/table> call. Eg:
__PACKAGE__->table('mydb.mytablename');
-And load all the Result classes for both / all databases using one
-L<DBIx::Class::Schema/load_namespaces> call.
+And load all the Result classes for both / all databases by calling
+L<DBIx::Class::Schema/load_namespaces>.
=item .. use DBIx::Class across PostgreSQL/DB2/Oracle schemas?
-Add the name of the schema to the L<DBIx::Class::ResultSource/table>
-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<table|DBIx::Class::ResultSourceProxy::Table/table>, and make sure the user
+you are about to connect as has permissions to read/write all the
+schemas/tables as necessary.
=back
=item .. use a relationship?
Use its name. An accessor is created using the name. See examples in
-L<DBIx::Class::Manual::Cookbook/Using relationships>.
+L<DBIx::Class::Manual::Cookbook/USING RELATIONSHIPS>.
=back
->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<search|DBIx::Class::ResultSet/search> and L<find|DBIx::Class::ResultSet/find>
+do not take L<DBIx::Class::InflateColumn> into account, and so your L<DateTime>
+object will not be correctly deflated into a format your RDBMS expects.
+
+The L<datetime_parser|DBIx::Class::Storage::DBI/datetime_parser> 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<C<result_source>|DBIx::Class::Row/result_source>.
+
+ my $dtf = $self->result_source->storage->datetime_parser;
+
+This kludge is necessary only for conditions passed to
+L<search|DBIx::Class::ResultSet/search> and L<DBIx::Class::ResultSet/find>,
+whereas L<create|DBIx::Class::ResultSet/create> and L<DBIx::Class::Row/update>
+(but not L<DBIx::Class::ResultSet/update>) are
+L<DBIx::Class::InflateColumn>-aware and will do the right thing when supplied
+an inflated L<DateTime> object.
=back
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:
L<http://dev.mysql.com/doc/refman/5.1/en/resetting-permissions.html>.
=back
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=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<hundres of DBIC contributors|DBIx::Class/AUTHORS> listed in
+F<AUTHORS>. That ranges from documentation help, to test help, to added
+features, to entire database support.
=head2 Active Community
) rpt_score
WHERE rno__row__index BETWEEN 1 AND 1
-See: L<DBIx::Class::ResultSet/related_resultset>, L<DBIx::ClassResultSet/search_related>, and L<DBIx::Class::ResultSet/get_column>.
+See: L<DBIx::Class::ResultSet/related_resultset>,
+L<DBIx::Class::ResultSet/search_related>, and
+L<DBIx::Class::ResultSet/get_column>.
=head2 bonus rel methods
price => \['price + ?', [inc => $inc]],
});
-See L<SQL::Abstract/Literal_SQL_with_placeholders_and_bind_values_(subqueries)>
+See L<SQL::Abstract/Literal SQL with placeholders and bind values (subqueries)>
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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</Result class> definitions.
+of table L</Result Class> definitions.
At least one L<DBIx::Class::Schema> 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</Result> objects
sometimes (incorrectly) called table objects.
ResultSources do not need to be directly created, a ResultSource
-instance is created for each L</Result class> in your L</Schema>, by
+instance is created for each L</Result Class> in your L</Schema>, by
the proxied methods C<table> and C<add_columns>.
See also: L<DBIx::Class::ResultSource/METHODS>
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<DBIx::Class::Manual::FAQ|the FAQ>.
+can be found in L<the FAQ|DBIx::Class::Manual::FAQ>.
=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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=back
-=cut
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
Or combine the two:
- join => { room => [ 'chair', { table => 'leg' } ]
+ join => { room => [ 'chair', { table => 'leg' } ] }
=head2 Table aliases
=cut
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
Continue with L<DBIx::Class::Tutorial> and
L<DBIx::Class/"WHERE TO START READING">.
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=back
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
White Box and Scientific Linux).
Distributions affected include Fedora 5 through to Fedora 8 and RHEL5
-upto and including RHEL5 Update 2. Fedora 9 (which uses perl 5.10) has
+up to and including RHEL5 Update 2. Fedora 9 (which uses perl 5.10) has
never been affected - this is purely a perl 5.8.8 issue.
As of September 2008 the following packages are known to be fixed and so
The solution is to use the smallest practical value for LongReadLen.
-=cut
+=head1 FURTHER QUESTIONS?
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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
# 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',
+ 'DBD::mysql' => '4.023',
+ },
+ },
-my $reqs = {
replicated => {
- req => $replicated,
+ req => $moose_basic,
pod => {
title => 'Storage::Replicated',
desc => 'Modules required for L<DBIx::Class::Storage::DBI::Replicated>',
},
test_replicated => {
+ include => 'replicated',
req => {
- %$replicated,
- 'Test::Moose' => '0',
+ 'Test::Moose' => '0',
},
},
+ config_file_reader => {
+ pod => {
+ title => 'Generic config reader',
+ desc => 'Modules required for generic config file parsing, currently Config::Any (rarely used at runtime)',
+ },
+ req => {
+ 'Config::Any' => '0.20',
+ },
+ },
admin => {
+ include => [qw( _json_any config_file_reader )],
req => {
- %$admin_basic,
+ %$moose_basic,
+ 'MooseX::Types::Path::Class' => '0.05',
+ 'MooseX::Types::JSON' => '0.02',
},
pod => {
title => 'DBIx::Class::Admin',
},
admin_script => {
+ include => 'admin',
req => {
- %$admin_script,
+ 'Getopt::Long::Descriptive' => '0.081',
+ 'Text::CSV' => '1.16',
},
pod => {
title => 'dbicadmin',
deploy => {
req => {
- 'SQL::Translator' => '0.11016',
+ 'SQL::Translator' => '0.11018',
},
pod => {
title => 'Storage::DBI::deploy()',
- desc => 'Modules required for L<DBIx::Class::Storage::DBI/deploy> and L<DBIx::Class::Storage::DBI/deployment_statements>',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI/deployment_statements> and L<DBIx::Class::Schema/deploy>',
+ },
+ },
+
+ ic_dt => {
+ req => {
+ 'DateTime' => '0.55',
+ 'DateTime::TimeZone::OlsonDB' => 0,
+ },
+ pod => {
+ title => 'InflateColumn::DateTime support',
+ desc =>
+ 'Modules required for L<DBIx::Class::InflateColumn::DateTime>. '
+ . '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<rbms_*> 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<DBIx::Class::CDBICompat>'
},
},
req => {
'Test::Pod' => '1.42',
},
+ release_testing_mandatory => 1,
},
test_podcoverage => {
'Test::Pod::Coverage' => '1.08',
'Pod::Coverage' => '0.20',
},
+ release_testing_mandatory => 1,
},
test_whitespace => {
'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,
},
},
- 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',
+ binary_data => {
+ pod => {
+ title => 'Binary datatype support (certain RDBMS)',
+ desc =>
+ 'Some RDBMS engines require specific versions of the respective DBD '
+ . 'driver for binary data support. Note that this group does not '
+ . 'require anything on its own, but instead is augmented by various '
+ . 'RDBMS-specific groups. See the documentation of each rbms_* group '
+ . 'for details',
},
},
# 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',
desc => 'Modules required to connect to PostgreSQL',
},
+ augment => {
+ binary_data => {
+ req => {
+ 'DBD::Pg' => '2.009002'
+ },
+ }
+ },
+ },
+
+ _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',
},
rdbms_mssql_sybase => {
+ include => '_rdbms_mssql_common',
req => {
- %$rdbms_mssql_sybase,
+ 'DBD::Sybase' => 0,
},
pod => {
title => 'MSSQL support via DBD::Sybase',
},
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',
},
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',
},
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',
},
},
+ _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',
},
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',
},
rdbms_informix => {
+ include => '_ic_dt_strptime_based',
req => {
- %$rdbms_informix,
+ 'DBD::Informix' => 0,
},
pod => {
title => 'Informix support',
},
},
+ _rdbms_sqlanywhere_common => {
+ include => '_ic_dt_strptime_based',
+ },
+
rdbms_sqlanywhere => {
+ include => '_rdbms_sqlanywhere_common',
req => {
- %$rdbms_sqlanywhere,
+ 'DBD::SQLAnywhere' => 0,
},
pod => {
title => 'SQLAnywhere support',
},
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',
},
rdbms_firebird_interbase => {
+ include => '_rdbms_firebird_common',
req => {
- %$rdbms_firebird_interbase,
+ 'DBD::InterBase' => 0,
},
pod => {
title => 'Firebird support via DBD::InterBase',
},
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_pg => {
+ include => 'rdbms_pg',
+ env => [
+ DBICTEST_PG_DSN => 1,
+ DBICTEST_PG_USER => 0,
+ DBICTEST_PG_PASS => 0,
+ ],
+ },
+
test_rdbms_mssql_odbc => {
- req => {
- $ENV{DBICTEST_MSSQL_ODBC_DSN}
- ? (
- %$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 => {
'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;
- my $deps = $reqs->{$group}{req}
- or Carp::croak "Requirement group '$group' does not exist";
+ if (@_) {
- return { %$deps };
+ 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");
+
+ if ( my $missing = $class->req_missing_for(\@_) ) {
+
+ 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" );
}
+# 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 die_unless_req_ok_for {
- my ($class, $group) = @_;
+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);
- Carp::croak "req_ok_for() expects a requirement group name"
- unless $group;
+ my $mods_missing = $reqs->{missing_envvars}
+ ? $self->_list_physically_missing_modules( $reqs->{modreqs} )
+ : $self->modreq_missing_for($groups)
+ ;
+
+ 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";
- Carp::croak "req_missing_for() expects a requirement group name"
- unless $group;
+ 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;
+ }
- return $class->_check_deps($group)->{missing};
+ 1;
}
-sub req_errorlist_for {
- my ($class, $group) = @_;
+sub die_unless_req_ok_for {
+ if (my $err = shift->req_missing_for(shift) ) {
+ die "Unable to continue due to missing requirements: $err\n";
+ }
+}
+
+
+
+### 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;
+ }
- Carp::croak "req_errorlist_for() expects a requirement group name"
- unless $group;
+ $last_prefix = $pref if $sep;
+ }
- return $class->_check_deps($group)->{errorlist};
+ 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 );
- return $req_availability_cache{$group} ||= do {
+ next if $seen->{$g}++;
- my $deps = $class->req_list_for ($group);
+ my $req_type = 'static';
- my %errors;
- for my $mod (keys %$deps) {
- my $req_line = "require $mod;";
- if (my $ver = $deps->{$mod}) {
- $req_line .= "$mod->VERSION($ver);";
+ if ( my @e = @{$r->{env}||[]} ) {
+
+ croak "Unexpected 'env' attribute under group '$g' (only allowed in test_* groups)"
+ unless $g =~ /^test_/;
+
+ 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 (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,
- };
+ 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;
+
+ 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) = @_;
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 ########################
#########################################################################
# 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<Module::Install>'s Makefile.PL):
+
+
+#@@
+#@@ SYNOPSIS HEADING
+#@@
+ push @chunks, <<"EOC";
+=head1 SYNOPSIS
+
+Somewhere in your build-file (e.g. L<ExtUtils::MakeMaker>'s F<Makefile.PL>):
...
- 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<configure_requires()>, more info
-can be found at L<Module::Install/configure_requires>
-EOS
- '=head1 DESCRIPTION',
- <<'EOD',
+ ExtUtils::MakeMaker::WriteMakefile(\%EUMM_ARGS);
+
+B<Note>: The C<eval> protection within the example is due to support for
+requirements during L<the C<configure> 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<CPAN> 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<configure> build phase
+will not be sufficiently ubiquitous until the B<year 2020> at the earliest,
+hence the extra care demonstrated above. It should also be noted that some
+3rd party installers (e.g. L<cpanminus|App::cpanminus>) 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<DBIx::Class> 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<groups> 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<groups|/CURRENT REQUIREMENT GROUPS> 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<test_> can specify
+a set of environment variables, some (or all) of which are marked as required
+for the group to be considered by L</req_list_for>
+
+Each group name (or a combination thereof) can be used in the
+L<public methods|/METHODS> as described below.
+EOC
- my $modlist = $reqs->{$group}{req}
- or next;
- next unless keys %$modlist;
+#@@
+#@@ REQUIREMENT GROUPLIST HEADING
+#@@
+ push @chunks, '=head1 CURRENT REQUIREMENT GROUPS';
+
+ 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</$ag> 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<Exporter>, it recognizes several C<actions>
+supplied to its C<import> 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<RELEASE_TESTING> environment variable and
+behaves like L</-die_without> for any requirement groups marked as
+C<release_testing_mandatory>.
+
+=head2 -die_without
+
+=over
+
+=item Arguments: @group_names
+
+=back
+
+A convenience wrapper around L</die_unless_req_ok_for>:
+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</modreq_missing_for>:
+
+ 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<keyed> by dependency group. Each key (group name), or a combination
+thereof (as an arrayref) can be supplied to the methods below.
+The B<values> of the returned hash are currently a set of options B<without a
+well defined structure>. 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<current> version of
-DBIx::Class. See the L</SYNOPSIS> 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</SYNOPSIS> for a real-world example.
+
+When handling C<test_*> groups this method behaves B<differently> from
+L</modreq_list_for> below (and is the only such inconsistency among the
+C<req_*> methods). If a particular group declares as requirements some
+C<environment variables> and these requirements are not satisfied (the envvars
+are unset) - then the C<module requirements> 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</req_list_for> but does not take into consideration any
+C<environment variable requirements> - 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<deploy> 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</req_ok_for> passes for the supplied C<$group_name>, and
+returning the actual error seen by the user. See also L</modreq_missing_for>
+
+=head2 modreq_missing_for
+
+=over
+
+=item Arguments: $group_name | \@group_names
+
+=item Return Value: $error_message_string
+
+=back
+
+Same as L</req_missing_for> 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<cpanminus|App::cpanminus>. 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<deploy> are not available,
+the returned string could look like:
+EOC
+
+ push @chunks, qq{ "SQL::Translator~$sqltver"};
+
+ push @chunks, <<'EOC';
+
+See also L</-list_missing>.
+
+=head2 skip_without
+
+=over
+
+=item Arguments: $group_name | \@group_names
+
+=back
+
+A convenience wrapper around L<skip|Test::More/SKIP>. It does not take neither
+a reason (it is generated by L</req_missing_for>) nor an amount of skipped tests
+(it is always C<1>, thus mandating unconditional use of
+L<done_testing|Test::More/done_testing>). Most useful in combination with ad hoc
+requirement specifications:
+EOC
+
+ push @chunks, <<EOC;
+ SKIP: {
+ $class->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</req_ok_for> passes for the supplied group(s), and
in case of failure throws an exception including the information
-from L</req_missing_for>.
-EOD
-
- '=head2 req_errorlist_for',
- '=over',
- '=item Arguments: $group_name',
- '=item Return Value: \%list_of_loaderrors_per_module',
- '=back',
- <<'EOD',
+from L</req_missing_for>. See also L</-die_without>.
+
+=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<DBIx::Class/CONTRIBUTORS>.',
- '=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</modreq_errorlist_for>.
+
+EOC
+
+#@@
+#@@ FOOTER
+#@@
+ push @chunks, <<'EOC';
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+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;
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</_siblings>
+a resultset with no ordering applied use C<_siblings>
=cut
sub siblings {
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});
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 ) {
$self->_shift_siblings ($direction, @between);
$self->_ordered_internal_update({ $position_column => $new_pos_val });
- $guard->commit;
+ $guard->commit if $guard;
return 1;
}
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 {
=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<DBIx::Class::Row/discard_changes>.
+If you have multiple same-group result objects already loaded from storage,
+you need to be careful when executing C<move_*> operations on them:
+without a L</position_column> reload the L</_position_value> 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<move_*> 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<DBIx::Class::Row/discard_changes> 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 <bluefeet@cpan.org>
-
- Constraints support and code generalisation
- Peter Rabbitson <ribasushi@cpan.org>
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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;
}
return \%cond;
}
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+1;
1;
+__END__
+
=head1 NAME
DBIx::Class::PK::Auto - Automatic primary key class
The code that was handled here is now in ResultSource, and is being proxied to
Row as well.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL
Just load PK::Auto instead; auto-inc is now handled by Storage.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL
Just load PK::Auto instead; auto-inc is now handled by Storage.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle
Just load PK::Auto instead; auto-inc is now handled by Storage.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1;
+__END__
+
=head1 NAME
DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite
Just load PK::Auto instead; auto-inc is now handled by Storage.
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
Base
/);
+1;
+
+__END__
+
=head1 NAME
DBIx::Class::Relationship - Inter-table relationships
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<cond> and C<attrs> are optional. Pass C<undef> for C<cond> if
you want to use the default value for it, but still want to set C<attrs>.
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<DBIx::Class::Relationship::Base/"create_related">.
attributes|DBIx::Class::ResultSet/ATTRIBUTES> which can be assigned to
relationships as well.
-=cut
-
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
-
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> 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<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=cut
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use strict;
use warnings;
-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 =
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;
use Scalar::Util qw/weaken blessed/;
use Try::Tiny;
+use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION';
use namespace::clean;
=head1 NAME
=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);
clause of the C<JOIN> statement associated with this relationship.
While every coderef-based condition must return a valid C<ON> 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<optional> join-free condition
+consisting of a hashref with B<all keys being fully qualified names of columns
+declared on the corresponding result source>. 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<always> in the form of a hashref. If a foreign result object is supplied
+(which is valid usage of L</set_from_related>), its values will be extracted
+into hashref form by calling L<get_columns|DBIx::Class::Row/get_columns>.
+
+=back
+
+Note that the above scenarios are mutually exclusive, that is you will be supplied
+none or only one of C<self_result_object> and C<foreign_values>. In other words if
+you define your condition coderef as:
sub {
my $args = shift;
"$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;
'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<DBIx::Class::Relationship::Base/set_from_related>. For
-instance the C<year> 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</set_from_related> (and by extension
+L<< $result->create_related|DBIx::Class::Relationship::Base/create_related >>),
+the returned join free condition B<must> contain only plain values/deflatable
+objects. For instance the C<year> 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<ON>
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
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');
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' },
});
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' } ],
});
The C<belongs_to> 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
=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
# 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') {
}
}
}
- 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},
);
}
};
=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
This is called internally when you pass existing objects as values to
L<DBIx::Class::ResultSet/create>, or pass an object to a belongs_to accessor.
-The columns are only set in the local copy of the object, call L</update> to
-set them in the storage.
+The columns are only set in the local copy of the object, call
+L<update|DBIx::Class::Row/update> 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;
}
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
use strict;
use warnings;
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
) unless $class->has_column($f_key);
$class->ensure_class_loaded($f_class);
- my $f_rsrc = try {
+ my $f_rsrc = dbic_internal_try {
$f_class->result_source_instance;
}
catch {
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;
$class->add_relationship($rel, $f_class,
$cond,
{
+ is_depends_on => 1,
accessor => $acc_type,
$fk_columns ? ( fk_columns => $fk_columns ) : (),
%{$attrs || {}}
return 1;
}
-# Attempt to remove the POD so it (maybe) falls off the indexer
-
-#=head1 AUTHORS
-#
-#Alexander Hartmaier <Alexander.Hartmaier@t-systems.at>
-#
-#Matt S. Trout <mst@shadowcatsystems.co.uk>
-#
-#=cut
-
1;
use strict;
use warnings;
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
my $ret = $self->next::method(@rest);
foreach my $rel (@cascade) {
- if( my $rel_rs = eval{ $self->search_related($rel) } ) {
+ if( my $rel_rs = dbic_internal_try { $self->search_related($rel) } ) {
$rel_rs->delete_all;
} else {
carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
use strict;
use warnings;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side appears already loaded
-# if (my $f_rsrc = try { $f_class->result_source_instance } ) {
+# if (my $f_rsrc = dbic_internal_try { $f_class->result_source_instance } ) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
join_type => 'LEFT',
cascade_delete => $default_cascade,
cascade_copy => $default_cascade,
+ is_depends_on => 0,
%{$attrs||{}}
});
}
use warnings;
use DBIx::Class::Carp;
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
# at this point we need to load the foreigner, expensive or not
$class->ensure_class_loaded($f_class);
- $f_rsrc = try {
+ $f_rsrc = dbic_internal_try {
my $r = $f_class->result_source_instance;
die "There got to be some columns by now... (exception caught and rewritten by catch below)"
unless $r->columns;
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side was not preloaded above *AND*
# # appears to have been loaded by something else (has a rsrc_instance)
-# if (! $f_rsrc and $f_rsrc = try { $f_class->result_source_instance }) {
+# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source_instance }) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
{ accessor => 'single',
cascade_update => $default_cascade,
cascade_delete => $default_cascade,
+ is_depends_on => 0,
($join_type ? ('join_type' => $join_type) : ()),
%{$attrs || {}} });
1;
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);
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 =
"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}";
}
}
- $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;
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 =
(
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 {
return $mk_hash->($_[2], $_[3], 'is_root');
}
+1;
+
+__END__
=head1 CAVEATS
=back
-=cut
+=head1 FURTHER QUESTIONS?
-1;
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use 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(
+ dbic_internal_try
+ 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 ();
A basic ResultSet representing the data of an entire table is returned
by calling C<resultset> on a L<DBIx::Class::Schema> and passing in a
-L<Source|DBIx::Class::Manual::Glossary/Source> name.
+L<Source|DBIx::Class::Manual::Glossary/ResultSource> name.
my $users_rs = $schema->resultset('User');
you want to check if a resultset has any results, you must use C<if $rs
!= 0>.
-=head1 CUSTOM ResultSet CLASSES THAT USE Moose
-
-If you want to make your custom ResultSet classes with L<Moose>, 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<MooseX::NonMoose> is necessary so that the L<Moose> constructor does not
-clash with the regular ResultSet constructor. Alternatively, you can use:
-
- __PACKAGE__->meta->make_immutable(inline_constructor => 0);
-
-The L<BUILDARGS|Moose::Manual::Construction/BUILDARGS> is necessary because the
-signature of the ResultSet C<new> is C<< ->new($source, \%args) >>.
-
=head1 EXAMPLES
=head2 Chaining resultsets
See: L</search>, L</count>, L</get_column>, L</all>, L</create>.
+=head2 Custom ResultSet classes
+
+To add methods to your resultsets, you can subclass L<DBIx::Class::ResultSet>, 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<DBIx::Class::Schema/load_namespaces> on how DBIC can discover and
+automatically attach L<Result|DBIx::Class::Manual::ResultClass>-specific
+L<ResulSet|DBIx::Class::ResultSet> classes.
+
+=head3 ResultSet subclassing with Moose and similar constructor-providers
+
+Using L<Moose> or L<Moo> 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<has xml_parser>, C<has json>, etc) or if you just prefer to organize
+your code via roles.
+
+In order to write custom ResultSet classes with L<Moo> you need to use the
+following template. The L<BUILDARGS|Moo/BUILDARGS> is necessary due to the
+unusual signature of the L<constructor provided by DBIC
+|DBIx::Class::ResultSet/new> 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<Moose>, you need
+a similar, though a little more elaborate template in order to interface the
+inlining of the L<Moose>-provided
+L<object constructor|Moose::Manual::Construction/WHERE'S THE CONSTRUCTOR?>,
+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<MooseX::NonMoose> is necessary so that the L<Moose> constructor does not
+entirely overwrite the DBIC one (in contrast L<Moo> does this automatically).
+Alternatively, you can skip L<MooseX::NonMoose> and get by with just L<Moose>
+instead by doing:
+
+ __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
=head1 METHODS
=head2 new
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;
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) {
$call_cond = shift;
}
# fish out attrs in the ($condref, $attr) case
- elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) {
+ elsif (@_ == 2 and ( ! defined $_[0] or length ref $_[0] ) ) {
($call_cond, $call_attrs) = @_;
}
elsif (@_ % 2) {
for my $i (0 .. $#_) {
next if $i % 2;
$self->throw_exception ('All keys in condition key/value pairs must be plain scalars')
- if (! defined $_[$i] or ref $_[$i] ne '');
+ if (! defined $_[$i] or length ref $_[$i] );
}
$call_cond = { @_ };
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] });
}
}
. "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,
# 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')
- } || ();
+ dbic_internal_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)
;
}
}
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
$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
For more information, see L<DBIx::Class::Manual::Cookbook>.
-This method is deprecated and will be removed in 0.09. Use L</search()>
+This method is deprecated and will be removed in 0.09. Use L<search()|/search>
instead. An example conversion is:
->search_like({ foo => 'bar' });
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};
$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 };
#
# 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 ) )
);
}
}
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 =
$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
Note that changing the result_class will also remove any components
that were originally loaded in the source class via
-L<DBIx::Class::ResultSource/load_components>. Any overloaded methods
-in the original source class will not run.
+L<load_components|Class::C3::Componentised/load_components( @comps )>.
+Any overloaded methods in the original source class will not run.
=cut
$guard = $storage->txn_scope_guard;
- $cond = [];
for my $row ($subrs->cursor->all) {
push @$cond, { map
{ $idcols->[$_] => $row->[$_] }
}
}
- my $res = $storage->$op (
+ my $res = $cond ? $storage->$op (
$rsrc,
$op eq 'update' ? $values : (),
$cond,
- );
+ ) : '0E0';
$guard->commit if $guard;
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
$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);
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
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
=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
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
return $row;
}
- return $self->create($cond);
+ return $self->new_result($cond)->insert;
}
=head2 update_or_new
=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;
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 {
# 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) {
});
}
-The current table alias can be altered with L</alias>.
+The alias of L<newly created resultsets|/search> can be altered by the
+L<alias attribute|/alias>.
=cut
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")
if $attrs->{collapse} and $attrs->{distinct};
+
+ # Sanity check the paging attributes
+ # SQLMaker does it too, but in case of a software_limit we'll never get there
+ if (defined $attrs->{offset}) {
+ $self->throw_exception('A supplied offset attribute must be a non-negative integer')
+ if ( $attrs->{offset} =~ /[^0-9]/ or $attrs->{offset} < 0 );
+ }
+ if (defined $attrs->{rows}) {
+ $self->throw_exception("The rows attribute must be a positive integer if present")
+ if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 );
+ }
+
+
# default selection list
$attrs->{columns} = [ $source->columns ]
unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/;
];
}
- 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)) {
- # 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 ( defined $attrs->{$attr} ) {
+ $attrs->{$attr} = (
+ ref( $attrs->{$attr} ) eq 'ARRAY'
+ ? [ @{ $attrs->{$attr} } ]
+ : [ $attrs->{$attr} || () ]
+ );
- 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
#
}
}
+
# generate the distinct induced group_by before injecting the prefetched select/as parts
if (delete $attrs->{distinct}) {
if ($attrs->{group_by}) {
}
}
- # 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
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 {
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<as> value, and the value is used as the C<select>
-expression). Adds C<me.> onto the start of any column without a C<.> in
+expression). Adds the L</current_source_alias> onto the start of any column without a C<.> in
it and sets C<select> from that, then auto-populates C<as> from
C<select> as normal. (You may also use the C<cols> attribute, as in
-earlier versions of DBIC, but this is deprecated.)
+earlier versions of DBIC, but this is deprecated)
Essentially C<columns> does the same as L</select> and L</as>.
- 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</prefetch>) 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<get_column> (see also
-L<SQL::Abstract/Literal-SQL-and-value-type-operators>):
+L<SQL::Abstract/Literal SQL and value type operators>):
- # equivalent SQL: SELECT 1, 'a string', IF(x,1,2) ...
+ # equivalent SQL: SELECT 1, 'a string', IF(my_column,?,?) ...
+ # bind values: $true_value, $false_value
columns => [
{
foo => \1,
bar => \q{'a string'},
- baz => \[ '?', 'IF(x,1,2)' ],
+ baz => \[ 'IF(my_column,?,?)', $true_value, $false_value ],
}
]
=head2 +columns
+B<NOTE:> You B<MUST> 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<columns>.
+
=over 4
-=item Value: \@columns
+=item Value: \@extra_columns
=back
Indicates additional columns to be selected from storage. Works the same as
-L</columns> but adds columns to the selection. (You may also use the
+L</columns> but adds columns to the current selection. (You may also use the
C<include_columns> attribute, as in earlier versions of DBIC, but this is
-deprecated). For example:-
+deprecated)
$schema->resultset('CD')->search(undef, {
'+columns' => ['artist.name'],
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
-B<NOTE:> 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</+columns> for backward compatibility.
-
=head2 select
=over 4
B<NOTE:> You will almost always need a corresponding L</as> attribute when you
use L</select>, to instruct DBIx::Class how to store the result of the column.
-Also note that the L</as> 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<ORDER BY> clause. This is done via the C<-as> B<select function
-attribute> supplied as shown in the example above.
-B<NOTE:> You need to explicitly quote '+select'/'+as' when defining the attributes.
-Not doing so causes Perl to incorrectly interpret them as a bareword with a
-unary plus operator before it.
+Also note that the L</as> attribute has B<nothing to do> with the SQL-side
+C<AS> identifier aliasing. You B<can> alias a function (so you can use it e.g.
+in an C<ORDER BY> clause), however this is done via the C<-as> B<select
+function attribute> supplied as shown in the example above.
=head2 +select
+B<NOTE:> You B<MUST> 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<select>.
+
=over 4
-Indicates additional columns to be selected from storage. Works the same as
-L</select> 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</select> but adds columns to the current selection, instead of specifying
+a new explicit list.
+
=head2 as
=over 4
=back
-Indicates column names for object inflation. That is L</as> indicates the
+Indicates DBIC-side names for object inflation. That is L</as> indicates the
slot name in which the column value will be stored within the
L<Row|DBIx::Class::Row> object. The value will then be accessible via this
identifier by the C<get_column> method (or via the object accessor B<if one
-with the same name already exists>) as shown below. The L</as> attribute has
-B<nothing to do> with the SQL-side C<AS>. See L</select> for details.
+with the same name already exists>) as shown below.
+
+The L</as> attribute has B<nothing to do> with the SQL-side identifier
+aliasing C<AS>. See L</select> for details.
$rs = $schema->resultset('Employee')->search(undef, {
select => [
=head2 +as
+B<NOTE:> You B<MUST> 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<as>.
+
=over 4
-Indicates additional column names for those added via L</+select>. See L</as>.
+=item Value: \@extra_inflation_names
=back
+Indicates additional inflation names for selectors added via L</+select>. See L</as>.
+
=head2 join
=over 4
This attribute is a shorthand for specifying a L</join> spec, adding all
columns from the joined related sources as L</+columns> and setting
-L</collapse> to a true value. For example, the following two queries are
-equivalent:
+L</collapse> to a true value. It can be thought of as a rough B<superset>
+of the L</join> attribute.
+
+For example, the following two queries are equivalent:
my $rs = $schema->resultset('Artist')->search({}, {
prefetch => { cds => ['genre', 'tracks' ] },
=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<secondary> condition applied to the set
+after the grouping calculations have been done. In other words it is a
+constraint just like L</where> (and accepting the same
+L<SQL::Abstract syntax|SQL::Abstract/WHERE CLAUSES>) applied to the data
+as it exists after GROUP BY has taken place. Specifying L</having> without
+L</group_by> 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
=head2 where
-=over 4
-
-Adds to the WHERE clause.
+Adds extra conditions to the resultset, combined with the preexisting C<WHERE>
+conditions, same as the B<first> argument to the L<search operator|/search>
# 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<SQL::Abstract/WHERE CLAUSES>.
-
-=back
+Note that the above example is
+L<strongly discouraged|DBIx::Class::ResultSource/resultset_attributes>.
=head2 cache
... do stuff ...
}
- $rs->first; # without cache, this would issue a query
+ $resultset->first; # without cache, this would issue a query
By default, searches are not cached.
[ undef, $val ] === [ {}, $val ]
$val === [ {}, $val ]
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+=cut
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';
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;
}
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) ];
}
}
};
}
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
}
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Carp;
+use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try );
+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;
L<DBIx::Class::ResultSourceProxy::Table> component, which defines
the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
When called, C<table> creates and stores an instance of
-L<DBIx::Class::ResultSoure::Table>. Luckily, to use tables as result
+L<DBIx::Class::ResultSource::Table>. 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
=head2 Finding result source objects
As mentioned above, a result source instance is created and stored for
-you when you define a L<result class|DBIx::Class::Manual::Glossary/Result class>.
+you when you define a
+L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
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
$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</column_info> for that column. Repeated
calls of this method will add more columns, not replace them.
restriction. This is currently only used to create tables from your
schema, see L<DBIx::Class::Schema/deploy>.
+ { size => [ 9, 6 ] }
+
+For decimal or float values you can specify an ArrayRef in order to
+control precision, assuming your database's
+L<SQL::Translator::Producer> 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<DBIx::Class::Schema/deploy>.
if ( ! $self->_columns->{$column}{data_type}
and ! $self->{_columns_info_loaded}
and $self->column_info_from_storage
- and my $stor = try { $self->storage } )
+ and my $stor = dbic_internal_try { $self->storage } )
{
$self->{_columns_info_loaded}++;
# try for the case of storage without table
- try {
+ dbic_internal_try {
my $info = $stor->columns_info_for( $self->from );
my $lc_info = { map
{ (lc $_) => $info->{$_} }
my $colinfo = $self->_columns;
if (
- first { ! $_->{data_type} } values %$colinfo
- and
! $self->{_columns_info_loaded}
and
$self->column_info_from_storage
and
- my $stor = try { $self->storage }
+ grep { ! $_->{data_type} } values %$colinfo
+ and
+ my $stor = dbic_internal_try { $self->storage }
) {
$self->{_columns_info_loaded}++;
# try for the case of storage without table
- try {
+ dbic_internal_try {
my $info = $stor->columns_info_for( $self->from );
my $lc_info = { map
{ (lc $_) => $info->{$_} }
Defines one or more columns as primary key for this source. Must be
called after L</add_columns>.
-Additionally, defines a L<unique constraint|add_unique_constraint>
+Additionally, defines a L<unique constraint|/add_unique_constraint>
named C<primary>.
Note: you normally do want to define a primary key on your sources
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);
my $name = $self->name;
$name = $$name if (ref $name eq 'SCALAR');
+ $name =~ s/ ^ [^\.]+ \. //x; # strip possible schema qualifier
return join '_', $name, @$cols;
}
$self->resultset_class->new(
$self,
{
- try { %{$self->schema->default_resultset_attributes} },
+ ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ),
%{$self->{resultset_attributes}},
},
);
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
# 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 };
$self->_relationships(\%rels);
return $self;
-
-# XXX disabled. doesn't work properly currently. skip in tests.
-
- my $f_source = $self->schema->source($f_source_name);
- unless ($f_source) {
- $self->ensure_class_loaded($f_source_name);
- $f_source = $f_source_name->result_source;
- #my $s_class = ref($self->schema);
- #$f_source_name =~ m/^${s_class}::(.*)$/;
- #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
- #$f_source = $self->schema->source($f_source_name);
- }
- return unless $f_source; # Can't test rel without f_source
-
- try { $self->_resolve_join($rel, 'me', {}, []) }
- catch {
- # If the resolve failed, back out and re-throw the error
- delete $rels{$rel};
- $self->_relationships(\%rels);
- $self->throw_exception("Error creating relationship $rel: $_");
- };
-
- 1;
}
=head2 relationships
=back
- my @relnames = $source->relationships();
+ my @rel_names = $source->relationships();
Returns all relationship names for this source.
# to use the source_names, otherwise we will use the actual classes
# the schema may be partial
- my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
or next;
if ($registered_source_name) {
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) = @_;
,
-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},
];
}
}
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};
- my $cond_cols;
- if ($joinfree_cond) {
+ $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);
+
+ # 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;
}
+ }
+
+ # 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;
- return wantarray
- ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 )
- : \%ret
- ;
+
+ $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
# if we are not registered with a schema - just use the prototype
# however if we do have a schema - ask for the source by name (and
# throw in the process if all fails)
- if (my $schema = try { $self->schema }) {
+ if (my $schema = dbic_internal_try { $self->schema }) {
$schema->source($self->relationship_info($rel)->{source});
}
else {
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;
######
$global_phase_destroy = 1;
};
- return;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
;
}
-=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
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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(
}
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:
});
};
+ utf8::upgrade($src)
+ if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE;
+
return (
$args->{eval} ? ( eval "sub $src" || die $@ ) : $src,
$check_null_columns,
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)
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(
# 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) = @_;
# 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
if (keys %$my_cols) {
my $branch_null_checks = join ' && ', map
- { "( ! defined '\xFF__VALPOS__${_}__\xFF' )" }
+ { "( ! defined \$_->[$_] )" }
sort { $a <=> $b } values %{$rel_cols->{$rel}}
;
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"} )
;
%{$args->{collapse_map}},
-custom_node_key => $top_node_key,
};
-
- $no_rowid_container = 0;
}
else {
die('Unexpected collapse map contents');
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
# 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
}
### 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);
}
}
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;
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 || '{}',
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,
);
}
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,
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;
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),
;
# 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),
}
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;
sub from { shift->name; }
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+1;
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
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
return $new;
}
-1;
-
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+1;
use base qw/DBIx::Class/;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
use overload
# 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');
}
}
elsif( my $rs = $from_class->result_source_instance ) {
# in the off-chance we are using CDBI-compat and have leaked $schema already
- if( my $s = try { $rs->schema } ) {
+ if( my $s = dbic_internal_try { $rs->schema } ) {
$self->schema( $s );
}
else {
}
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Ash Berlin C<< <ash@cpan.org> >>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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');
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;
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);
the various types of column data in this hashref, see
L<DBIx::Class::ResultSource/add_column>
-=cut
-
=head2 columns
my @column_names = $obj->columns;
-=cut
+=head1 FURTHER QUESTIONS?
-1;
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 COPYRIGHT AND LICENSE
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-=head1 LICENSE
+=cut
-You may distribute this code under the same terms as Perl itself.
+1;
-=cut
use Scalar::Util 'blessed';
use List::Util 'first';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Carp;
+use SQL::Abstract qw( is_literal_value is_plain_value );
###
### Internal method
object (such as a typical C<< L<search|DBIx::Class::ResultSet/search>->
L<next|DBIx::Class::ResultSet/next> >> call) are actually Result
instances, based on your application's
-L<Result class|DBIx::Class::Manual::Glossary/Result_class>.
+L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
L<DBIx::Class::Row> implements most of the row-based communication with the
underlying storage, but a Result class B<should not inherit from it directly>.
## 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);
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
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;
}
$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});
}
# 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)
) {
$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
$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 {
Indicates whether the object exists as a row in the database or
not. This is set to true when L<DBIx::Class::ResultSet/find>,
-L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
-are used.
+L<DBIx::Class::ResultSet/create> or L<DBIx::Class::Row/insert>
+are invoked.
Creating a result object using L<DBIx::Class::ResultSet/new_result>, or
calling L</delete> on one, sets it to false.
$self->in_storage(0);
}
else {
- my $rsrc = try { $self->result_source_instance }
+ my $rsrc = dbic_internal_try { $self->result_source_instance }
or $self->throw_exception("Can't do class delete without a ResultSource instance");
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
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;
}
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
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}) {
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};
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 );
}
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 (
! defined $colinfo->{is_numeric}
and
- my $storage = try { $self->result_source->schema->storage }
+ my $storage = dbic_internal_try { $self->result_source->schema->storage }
) {
$colinfo->{is_numeric} =
$storage->is_datatype_numeric ($colinfo->{data_type})
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) {
#
# 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};
}
}
$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}
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;
}
# 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
=head2 set_inflated_columns
- $result->set_inflated_columns({ $col => $val, $relname => $obj, ... });
+ $result->set_inflated_columns({ $col => $val, $rel_name => $obj, ... });
=over
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);
"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});
}
}
sub copy {
my ($self, $changes) = @_;
$changes ||= {};
- my $col_data = { %{$self->{_column_data}} };
+ my $col_data = { $self->get_columns };
+
+ my $rsrc = $self->result_source;
- my $colinfo = $self->columns_info([ keys %$col_data ]);
+ 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;
}
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;
+
+ return $self->{_column_data}{$column} = $value
+ unless length ref $value and my $vref = is_plain_value( $value );
+
+ # if we are dealing with a value/ref - there are a couple possibilities
+ # unpack the underlying piece of data and stringify all objects explicitly
+ # ( to accomodate { -value => ... } and guard against overloaded objects
+ # with defined stringification AND fallback => 0 (ugh!)
+ $self->{_column_data}{$column} = defined blessed $$vref
+ ? "$$vref"
+ : $$vref
+ ;
}
=head2 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);
}
}
=back
-L</Update>s the object if it's already in the database, according to
+L</update>s the object if it's already in the database, according to
L</in_storage>, else L</insert>s it.
=head2 insert_or_update
# 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(...) ?"
)
}
;
second argument to C<< $resultset->search($cond, $attrs) >>;
Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
-storage, please kept in mind that if you L</discard_changes> 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
sub throw_exception {
my $self=shift;
- if (ref $self && ref $self->result_source ) {
- $self->result_source->throw_exception(@_)
+ if (
+ ref $self
+ and
+ my $rsrc = dbic_internal_try { $self->result_source_instance }
+ ) {
+ $rsrc->throw_exception(@_)
}
else {
DBIx::Class::Exception->throw(@_);
Returns the primary key(s) for a row. Can't be called as a class method.
Actually implemented in L<DBIx::Class::PK>
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
=head1 DESCRIPTION
-This module is a subclass of L<SQL::Abstract> and includes a number of
-DBIC-specific workarounds, not yet suitable for inclusion into the
+This module is currently a subclass of L<SQL::Abstract> and includes a number of
+DBIC-specific extensions/workarounds, not suitable for inclusion into the
L<SQL::Abstract> core. It also provides all (and more than) the functionality
of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for
more info.
-Currently the enhancements to L<SQL::Abstract> are:
+Currently the enhancements over L<SQL::Abstract> are:
=over
=item * C<GROUP BY>/C<HAVING> 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<SQL::Abstract (SQLA)|SQL::Abstract> 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<very> distinct life on its own, and is used within an
+order of magnitude more projects compared to DBIC, it is prudent to B<not>
+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<DBIC will no
+longer depend on SQLA> at all.
+
+B<The L<SQL::Abstract> 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<SQL::Abstract> 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<case|SQL::Abstract/case> or L<logic|SQL::Abstract/logic>
+or even worse L<convert|SQL::Abstract/convert> 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<Data::Query> 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<SQL::Abstract> 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<Data::Query (DQ)|Data::Query>
+
+When initial work on DQ was taking place, the tools in L<::Storage::DBIHacks
+|http://github.com/dbsrgits/dbix-class/blob/master/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<regexing all over the place> 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<real soon now (tm)>, 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/
__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 ) )
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')
- if ( $offset =~ /\D/ or $offset < 0 );
+ if ( $offset =~ /[^0-9]/ or $offset < 0 );
}
$offset ||= 0;
if (defined $limit) {
$self->throw_exception('A supplied limit must be a positive integer')
- if ( $limit =~ /\D/ or $limit <= 0 );
+ if ( $limit =~ /[^0-9]/ or $limit <= 0 );
}
elsif ($offset) {
$limit = $self->__max_int;
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'
# 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(
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()} );
# 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});
}
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 {
# 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
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' ) {
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 {
\[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ];
}
-1;
-
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
=head2 LimitXY
- SELECT ... LIMIT $offset $limit
+ SELECT ... LIMIT $offset, $limit
Supported by B<MySQL> and any L<SQL::Statement> based DBD
SELECT SKIP $offset FIRST $limit * FROM ...
-Suported by B<Informix>, almost like LimitOffset. According to
+Supported by B<Informix>, almost like LimitOffset. According to
L<SQL::Abstract::Limit> C<... SKIP $offset LIMIT $limit ...> is also supported.
=cut
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)
or
SELECT * FROM (
- SELECT *, ROWNUM rownum__index FROM (
+ SELECT *, ROWNUM AS rownum__index FROM (
SELECT ...
)
) WHERE rownum__index BETWEEN ($offset+1) AND ($limit+$offset)
# 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/}
)
) {
return <<EOS;
SELECT $sq_attrs->{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 >= ?
return <<EOS;
SELECT $sq_attrs->{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 ?
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},
$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) );
} )
];
}
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};
};
# 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);
($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, [
$inner_order_sql
", map { $self->_quote ($_) } (
$rs_attrs->{alias},
- $root_tbl_name,
+ $main_tbl_name,
$count_tbl_alias,
));
}
#
# 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)
#
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
return $fqcn;
}
-1;
-
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
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]} : @_;
@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)
&& $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 };
1;
-=pod
+__END__
=head1 NAME
=back
-=head1 AUTHOR
-
-Justin Wheeler C<< <jwheeler@datademons.com> >>
-
-=head1 CONTRIBUTORS
-
-David Jack Olrik C<< <djo@cpan.org> >>
-
-=head1 LICENSE
+=head1 FURTHER QUESTIONS?
-This module is licensed under the same terms as Perl itself.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=cut
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use 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 scope_guard
+ is_exception dbic_internal_try
+);
use Devel::GlobalDestruction;
use namespace::clean;
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</resultset_class> 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<resultset_class|DBIx::Class::ResultSource/resultset_class> 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
my $me = shift;
my $rs_class = ref ($_[0]) || $_[0];
- return try {
+ return dbic_internal_try {
$rs_class->result_source_instance
} catch {
$me->throw_exception (
$storage_class =~ s/^::/DBIx::Class::Storage::/;
- try {
+ dbic_internal_try {
$self->ensure_class_loaded ($storage_class);
}
catch {
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);
}
}
- 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;
=cut
sub throw_exception {
- my $self = shift;
+ my ($self, @args) = @_;
+
+ if (
+ ! DBIx::Class::_Util::in_internal_try()
+ and
+ my $act = $self->exception_action
+ ) {
+
+ my $guard_disarmed;
+
+ my $guard = scope_guard {
+ return if $guard_disarmed;
+ local $SIG{__WARN__};
+ Carp::cluck("
+ !!! DBIx::Class INTERNAL PANIC !!!
+
+The exception_action() handler installed on '$self'
+aborted the stacktrace below via a longjmp (either via Return::Multilevel or
+plain goto, or Scope::Upper or something equally nefarious). There currently
+is nothing safe DBIx::Class can do, aside from displaying this error. A future
+version ( 0.082900, when available ) will reduce the cases in which the
+handler is invoked, but this is neither a complete solution, nor can it do
+anything for other software that might be affected by a similar problem.
+
+ !!! FIX YOUR ERROR HANDLING !!!
- if (my $act = $self->exception_action) {
- if ($act->(@_)) {
- DBIx::Class::Exception->throw(
+This guard was activated beginning"
+ );
+ };
+
+ eval {
+ # if it throws - good, we'll assign to @args in the end
+ # 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])"
- );
+ .' exception mechanism, ensure your exception_action does not hide exceptions'
+ ." (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'
+ );
+ }
+
+ 1;
}
- 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.'
+ or
+
+ # 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 this do{} block
+ is_exception(
+ $args[0] = $@
);
+
+ # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125
+ $guard_disarmed = 1;
}
- DBIx::Class::Exception->throw($_[0], $self->stacktrace);
+ DBIx::Class::Exception->throw( $args[0], $self->stacktrace );
}
=head2 deploy
A convenient shortcut to
C<< $self->storage->deployment_statements($self, @args) >>.
-Returns the SQL statements used by L</deploy> and
-L<DBIx::Class::Schema::Storage/deploy>.
+Returns the statements used by L</deploy> and
+L<DBIx::Class::Storage/deploy>.
=cut
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<Storable/nfreeze>, it is just
-provided here for symmetry.
+This doesn't actually do anything beyond calling L<nfreeze|Storable/SYNOPSIS>,
+it is just provided here for symmetry.
=cut
sub freeze {
- require Storable;
return Storable::nfreeze($_[1]);
}
sub dclone {
my ($self, $obj) = @_;
local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
- require Storable;
return Storable::dclone($obj);
}
return $source if $params->{extra};
my $rs_class = $source->result_class;
- if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
+ if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) {
my %map = %{$self->class_mappings};
if (
exists $map{$rs_class}
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;
last;
}
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub _unregister_source {
carp_once "compose_connection deprecated as of 0.08000"
unless $INC{"DBIx/Class/CDBICompat.pm"};
- my $base = 'DBIx::Class::ResultSetProxy';
- try {
- eval "require ${base};"
+ dbic_internal_try {
+ 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) {
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);
}
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) {
return $schema;
}
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
use base 'DBIx::Class::Schema';
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use Time::HiRes qw/gettimeofday/;
-use Try::Tiny;
+use Scalar::Util 'weaken';
use namespace::clean;
__PACKAGE__->mk_classdata('_filedata');
Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
-See L</getting_started> for more details.
+See L</GETTING STARTED> for more details.
=cut
my ($self, $rs) = @_;
my $vtable = $self->{vschema}->resultset('Table');
- my $version = try {
+ my $version = dbic_internal_try {
$vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
->get_column ('version')
->next;
{
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');
# 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);
}
}
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({
# 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,
$dt[0],
int($tm[1] / 1000), # convert to millisecs
),
- });
+ })->insert;
}
sub _read_sql_file {
sub _source_exists
{
- my ($self, $rs) = @_;
-
- return try {
- $rs->search(\'1=0')->cursor->next;
- 1;
- } catch {
- 0;
- };
+ my ($self, $rs) = @_;
+
+ ( dbic_internal_try {
+ $rs->search(\'1=0')->cursor->next;
+ 1;
+ } )
+ ? 1
+ : 0
+ ;
}
-1;
+=head1 FURTHER QUESTIONS?
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 COPYRIGHT AND LICENSE
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-=head1 LICENSE
+=cut
-You may distribute this code under the same terms as Perl itself.
+1;
The deserializing hook called on the object during deserialization.
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use strict;
use warnings;
+1;
+
+__END__
+
=head1 NAME
DBIx::Class::StartupCheck - Run environment checks on startup
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<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use DBIx::Class::Storage::BlockRunner;
use Scalar::Util qw/blessed weaken/;
use DBIx::Class::Storage::TxnScopeGuard;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
$self = ref $self if ref $self;
my $new = bless( {
- transaction_depth => 0,
savepoints => [],
}, $self);
$self->debugobj->txn_commit() if $self->debug;
$self->_exec_txn_commit;
$self->{transaction_depth}--;
+ $self->savepoints([]);
}
elsif($self->transaction_depth > 1) {
$self->{transaction_depth}--;
if ($self->transaction_depth == 1) {
$self->debugobj->txn_rollback() if $self->debug;
- $self->_exec_txn_rollback;
$self->{transaction_depth}--;
+
+ # in case things get really hairy - just disconnect
+ dbic_internal_try { $self->_exec_txn_rollback; 1 } or do {
+ my $rollback_error = $@;
+
+ # whatever happens, too low down the stack to care
+ # FIXME - revisit if stackable exceptions become a thing
+ dbic_internal_try { $self->disconnect };
+
+ die $rollback_error;
+ };
+
+ $self->savepoints([]);
}
elsif ($self->transaction_depth > 1) {
$self->{transaction_depth}--;
}
}
+# to be called by several internal stacked transaction handler codepaths
+# not for external consumption
+# *DOES NOT* throw exceptions, instead:
+# - returns false on success
+# - returns the exception on failed rollback
+sub __delicate_rollback {
+ my $self = shift;
+
+ if (
+ ( $self->transaction_depth || 0 ) > 1
+ and
+ # FIXME - the autosvp check here shouldn't be happening, it should be a role-ish thing
+ # The entire concept needs to be rethought with the storage layer... or something
+ ! $self->auto_savepoint
+ and
+ # the handle seems healthy, and there is nothing for us to do with it
+ # just go ahead and bow out, without triggering the txn_rollback() "nested exception"
+ # the unwind will eventually fail somewhere higher up if at all
+ # FIXME: a ::Storage::DBI-specific method, not a generic ::Storage one
+ $self->_seems_connected
+ ) {
+ # all above checks out - there is nothing to do on the $dbh itself
+ # just a plain soft-decrease of depth
+ $self->{transaction_depth}--;
+ return;
+ }
+
+ my @args = @_;
+ my $rbe;
+
+ dbic_internal_try {
+ $self->txn_rollback; 1
+ }
+ catch {
+
+ $rbe = $_;
+
+ # we were passed an existing exception to augment (think DESTROY stacks etc)
+ if (@args) {
+ my ($exception) = @args;
+
+ # append our text - THIS IS A TEMPORARY FIXUP!
+ #
+ # If the passed in exception is a reference, or an object we don't know
+ # how to augment - flattening it is just damn rude
+ if (
+ # FIXME - a better way, not liable to destroy an existing exception needs
+ # to be created. For the time being perpetuating the sin below in order
+ # to break the deadlock of which yak is being shaved first
+ 0
+ and
+ length ref $$exception
+ and
+ (
+ ! defined blessed $$exception
+ or
+ ! $$exception->isa( 'DBIx::Class::Exception' )
+ )
+ ) {
+
+ ##################
+ ### FIXME - TODO
+ ##################
+
+ }
+ else {
+
+ # SUCH HIDEOUS, MUCH AUGH! (and double WOW on the s/// at the end below)
+ $rbe =~ s/ at .+? line \d+$//;
+
+ (
+ (
+ defined blessed $$exception
+ and
+ $$exception->isa( 'DBIx::Class::Exception' )
+ )
+ ? (
+ $$exception->{msg} =
+ "Transaction aborted: $$exception->{msg}. Rollback failed: $rbe"
+ )
+ : (
+ $$exception =
+ "Transaction aborted: $$exception. Rollback failed: $rbe"
+ )
+ ) =~ s/Transaction aborted: (?=Transaction aborted:)//;
+ }
+ }
+ };
+
+ return $rbe;
+}
+
=head2 svp_begin
Arguments: $savepoint_name?
=head2 debugfh
-Set or retrieve the filehandle used for trace/debug output. This should be
-an IO::Handle compatible object (only the C<print> method is used). Initially
-set to be STDERR - although see information on the
-L<DBIC_TRACE> environment variable.
+An opportunistic proxy to L<< ->debugobj->debugfh(@_)
+|DBIx::Class::Storage::Statistics/debugfh >>
+If the currently set L</debugobj> does not have a L</debugfh> method, caling
+this is a no-op.
=cut
my @pp_args;
if ($profile =~ /^\.?\//) {
- require Config::Any;
- my $cfg = try {
+ if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('config_file_reader') ) {
+ $self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing");
+ }
+
+ my $cfg = dbic_internal_try {
Config::Any->load_files({ files => [$profile], use_ext => 1 });
} catch {
# sanitize the error message a bit
#
# Yes I am aware this is fragile and TxnScopeGuard needs
# a better fix. This is another yak to shave... :(
- try {
+ dbic_internal_try {
DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
} catch {
$self->throw_exception($_);
used as the configuration for tracing. See L<SQL::Abstract::Tree/new>
for what that structure should look like.
-
=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
Old name for DBIC_TRACE
L<DBIx::Class::Storage::DBI> - reference storage implementation using
SQL::Abstract and DBI.
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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 dbic_internal_try );
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
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,
);
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,
);
my $run_err = '';
return preserve_context {
- try {
+ dbic_internal_try {
if (defined $txn_init_depth) {
$self->storage->txn_begin;
$txn_begin_ok = 1;
my @res = @_;
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
+ and
+ defined( my $cur_depth = $storage->transaction_depth )
+ ) {
my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
if ($delta_txn) {
) unless $delta_txn == 1 and $cur_depth == 0;
}
else {
- $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
+ dbic_internal_try {
+ $storage->txn_commit;
+ 1;
+ }
+ catch {
+ $run_err = $_;
+ };
}
}
# something above threw an error (could be the begin, the code or the commit)
if ( is_exception $run_err ) {
- # attempt a rollback if we did begin in the first place
- if ($txn_begin_ok) {
- # some DBDs go crazy if there is nothing to roll back on, perform a soft-check
- my $rollback_exception = $storage->_seems_connected
- ? (! eval { $storage->txn_rollback; 1 }) ? $@ : ''
- : 'lost connection to storage'
- ;
-
- if ( $rollback_exception and (
- ! defined blessed $rollback_exception
- or
- ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
- ) ) {
- $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
- }
- }
+ # Attempt a rollback if we did begin in the first place
+ # Will append rollback error if possible
+ $storage->__delicate_rollback( \$run_err )
+ if $txn_begin_ok;
push @{ $self->exception_stack }, $run_err;
};
}
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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
+ dbic_internal_try
+ detected_reinvoked_destructor scope_guard
+);
use namespace::clean;
# default cursor class, overridable in connect_info attributes
txn_begin
insert
- insert_bulk
update
delete
select
select_single
+ _insert_bulk
+
with_deferred_fk_checks
get_use_dbms_capability
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]
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
) {
$_[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
weaken (
$seek_and_destroy{ refaddr($_[0]) } = $_[0]
);
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
END {
- local $?; # just in case the DBI destructor changes it somehow
- # destroy just the object if not native to this process
- $_->_verify_pid for (grep
- { defined $_ }
- values %seek_and_destroy
- );
+ if(
+ ! DBIx::Class::_ENV_::BROKEN_FORK
+ and
+ my @instances = grep { defined $_ } values %seek_and_destroy
+ ) {
+ local $?; # just in case the DBI destructor changes it somehow
+
+ # disarm the handle if not native to this process (see comment on top)
+ $_->_verify_pid for @instances;
+ }
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub CLONE {
for (@instances) {
$_->_dbh(undef);
-
- $_->transaction_depth(0);
- $_->savepoints([]);
+ $_->disconnect;
# properly renumber existing refs
$_->_arm_global_destructor
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
}
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;
+ return unless defined $_[0]->_dbh;
+
local $SIG{__WARN__} = sub {};
- $self->_dbh(undef);
+ $_[0]->_dbh(undef);
+ # not calling ->disconnect here - we are being destroyed - nothing to reset
- # this op is necessary, since the very last perl runtime statement
- # triggers a global destruction shootout, and the $SIG localization
- # may very well be destroyed before perl actually gets to do the
- # $dbh undef
- 1;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
# 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]->disconnect;
}
- return;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
=head2 connect_info
=cut
sub disconnect {
- my ($self) = @_;
+ my $self = shift;
- if( $self->_dbh ) {
- my @actions;
+ # this physical disconnect below might very well throw
+ # in order to unambiguously reset the state - do the cleanup in guard
+
+ my $g = scope_guard {
+
+ {
+ local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
+ eval { $self->_dbh->disconnect };
+ }
+
+ $self->_dbh(undef);
+ $self->_dbh_details({});
+ $self->transaction_depth(undef);
+ $self->_dbh_autocommit(undef);
+ $self->savepoints([]);
+
+ # FIXME - this needs reenabling with the proper "no reset on same DSN" check
+ #$self->_sql_maker(undef); # this may also end up being different
+ };
- push @actions, ( $self->on_disconnect_call || () );
- push @actions, $self->_parse_connect_do ('on_disconnect_do');
+ if( $self->_dbh ) {
- $self->_do_connection_actions(disconnect_call_ => $_) for @actions;
+ $self->_do_connection_actions(disconnect_call_ => $_) for (
+ ( $self->on_disconnect_call || () ),
+ $self->_parse_connect_do ('on_disconnect_do')
+ );
# stops the "implicit rollback on disconnect" warning
$self->_exec_txn_rollback unless $self->_dbh_autocommit;
-
- %{ $self->_dbh->{CachedKids} } = ();
- $self->_dbh->disconnect;
- $self->_dbh(undef);
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
=head2 with_deferred_fk_checks
# Storage subclasses should override this
sub with_deferred_fk_checks {
- my ($self, $sub) = @_;
- $sub->();
+ #my ($self, $sub) = @_;
+ $_[1]->();
}
=head2 connected
=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;
+ $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- my $dbh = $self->_dbh
- or return 0;
+ $_[0]->_dbh
+ and
+ $_[0]->_dbh->FETCH('Active')
+ and
+ return 1;
- return $dbh->FETCH('Active');
+ # explicitly reset all state
+ $_[0]->disconnect;
+ return 0;
}
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
=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;
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
+ # reset internal states
+ # also in case ->connected failed we might get sent here
+ $_[0]->disconnect;
- $self->_dbh($self->_connect);
+ $_[0]->_dbh($_[0]->_connect);
- $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
+ $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
- $self->_determine_driver;
+ $_[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'),
+ );
}
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 {
- $info = {};
+ # this guarantees that problematic conninfo won't be hidden
+ # by the try{} below
+ $self->ensure_connected;
+
+ my $info = {};
- my $server_version = try {
+ my $server_version = dbic_internal_try {
$self->_get_server_version
} catch {
# driver determination *may* use this codepath
}
$self->_dbh_details->{info} = $info;
- }
-
- return $info;
+ };
}
sub _get_server_version {
my $self = shift;
my $drv;
- try {
+ dbic_internal_try {
$drv = $self->_extract_driver_from_connect_info;
$self->ensure_connected;
};
DBIC_DRIVER => ref $self,
$drv ? (
DBD => $drv,
- DBD_VER => try { $drv->VERSION },
+ DBD_VER => dbic_internal_try { $drv->VERSION },
) : (),
};
) {
# some drivers barf on things they do not know about instead
# of returning undef
- my $v = try { $self->_dbh_get_info($inf) };
+ my $v = dbic_internal_try { $self->_dbh_get_info($inf) };
next unless defined $v;
#my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} );
"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
);
}
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(
}
}
+sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') }
+
sub _warn_undetermined_driver {
my ($self, $msg) = @_;
}
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) = @_;
+
+ dbic_internal_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->disconnect; # the $dbh is gone, but we still need to reset the rest
+ $self->throw_exception( $_[0] );
+ }
+ else {
+ carp "Disconnect action failed: $_[0]";
+ }
+ };
return $self;
}
$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<connection option|/DBIx::Class specific connection attributes>
+
+ 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 {
}, '__DBIC__DBH__ERROR__HANDLER__';
};
- try {
+ dbic_internal_try {
if(ref $info->[0] eq 'CODE') {
$dbh = $info->[0]->();
}
}
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 {
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') ) {
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;
+ # do a minimal connectivity check due to weird shit like
+ # https://rt.cpan.org/Public/Bug/Display.html?id=62370
+ $self->throw_exception("lost connection to storage")
+ unless $self->_seems_connected;
# esoteric case for folks using external $dbh handles
if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
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
) {
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'
}
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}) {
};
return [ map {
- 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] }
), $_->[1] ]
- ;
-
- if (
- ! exists $resolved->[0]{dbd_attrs}
- and
- ! $resolved->[0]{sqlt_datatype}
- and
- length ref $resolved->[1]
- and
- ! overload::Method($resolved->[1], '""')
- ) {
- require Data::Dumper;
- local $Data::Dumper::Maxdepth = 1;
- local $Data::Dumper::Terse = 1;
- local $Data::Dumper::Useqq = 1;
- local $Data::Dumper::Indent = 0;
- local $Data::Dumper::Pad = ' ';
- $self->throw_exception(
- 'You must supply a datatype/bindtype (see DBIx::Class::ResultSet/DBIC BIND VALUES) '
- . 'for non-scalar value '. Data::Dumper::Dumper ($resolved->[1])
- );
- }
-
- $resolved;
-
} @$bind ];
}
}
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 {
- return \@attrs;
+ # 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}};
+
+ $cache->{$_->{sqlt_datatype}};
+
+ } } map { $_->[0] } @{$_[2]} ];
}
sub _execute {
);
}
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],
);
(
! 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(
}
# 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 (
my %returned_cols = %$to_insert;
if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set
- @ir_container = try {
- local $SIG{__WARN__} = sub {};
- my @r = $sth->fetchrow_array;
- $sth->finish;
- @r;
- } unless @ir_container;
+
+ unless( @ir_container ) {
+ dbic_internal_try {
+
+ # FIXME - need to investigate why Caelum silenced this in 4d4dc518
+ local $SIG{__WARN__} = sub {};
+
+ @ir_container = $sth->fetchrow_array;
+ $sth->finish;
+
+ } catch {
+ # Evict the $sth from the cache in case we got here, since the finish()
+ # is crucial, at least on older Firebirds, possibly on other engines too
+ #
+ # It would be too complex to make this a proper subclass override,
+ # and besides we already take the try{} penalty, adding a catch that
+ # triggers infrequently is a no-brainer
+ #
+ if( my $kids = $self->_dbh->{CachedKids} ) {
+ $kids->{$_} == $sth and delete $kids->{$_}
+ for keys %$kids
+ }
+ };
+ }
@returned_cols{@$retlist} = @ir_container if @ir_container;
}
}
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
;
# 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(
# 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]
] ];
}
}
[ $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
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')",
);
}
}
- 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);
}
}
}
# 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,
# 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) {
}
};
- $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
+ $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
$guard->commit;
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],
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
+ my $vref;
+
+ ( !length ref $v or ! ($vref = is_plain_value $v) ) ? $v
+ : defined blessed( $$vref ) ? "$$vref"
+ : $$vref
+ ;
+ } map { $_->[0] } @$proto_bind ];
};
my $tuple_status = [];
my ($rv, $err);
- try {
+ dbic_internal_try {
$rv = $sth->execute_for_fetch(
$fetch_tuple,
$tuple_status,
);
# Statement must finish even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
catch {
my ($self, $sth, $count) = @_;
my $err;
- try {
+ dbic_internal_try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
};
# Make sure statement is finished even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
catch {
#) 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
- # in case of a software_limit we'll never reach there)
- if (defined $attrs->{offset}) {
- $self->throw_exception('A supplied offset attribute must be a non-negative integer')
- if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
- }
-
- if (defined $attrs->{rows}) {
- $self->throw_exception("The rows attribute must be a positive integer if present")
- if ( $attrs->{rows} =~ /\D/ or $attrs->{rows} <= 0 );
- }
- elsif ($attrs->{offset}) {
- # MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = $sql_maker->__max_int;
- }
+ # MySQL actually recommends this approach. I cringe.
+ $attrs->{rows} ||= $sql_maker->__max_int
+ if $attrs->{offset};
# see if we will need to tear the prefetch apart to satisfy group_by == select
# this is *extremely tricky* to get right, I am still not sure I did
# 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
@{$attrs->{group_by}}
and
- my $grp_aliases = try { # try{} because $attrs->{from} may be unreadable
+ my $grp_aliases = dbic_internal_try { # internal_try{} because $attrs->{from} may be unreadable
$self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} })
}
) {
$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
sub _dbh_columns_info_for {
my ($self, $dbh, $table) = @_;
- if ($dbh->can('column_info')) {
- my %result;
- my $caught;
- try {
+ my %result;
+
+ if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) {
+ dbic_internal_try {
my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
$sth->execute();
$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;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+ my $id = dbic_internal_try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
return $id if defined $id;
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- return try {
+ ( dbic_internal_try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
1;
- }
- catch {
- 0;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
# Check if placeholders bound to non-string types throw exceptions
my $self = shift;
my $dbh = $self->_get_dbh;
- return try {
+ ( dbic_internal_try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
# this specifically tests a bind that is NOT a string
$dbh->do('select 1 where 1 = ?', {}, 1);
1;
- }
- catch {
- 0;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
=head2 sqlt_type
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 );
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;
=back
-Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+Returns the statements used by L<DBIx::Class::Storage/deploy>
+and L<DBIx::Class::Schema/deploy>.
The L<SQL::Translator> (not L<DBI>) database driver name can be explicitly
provided in C<$type>, otherwise the result of L</sqlt_type> is used as default.
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
$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,
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- try {
+ dbic_internal_try {
# do a dbh_do cycle here, as we need some error checking in
# place (even though we will ignore errors)
$self->dbh_do (sub { $_[1]->do($line) });
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<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
$self->_exec_txn_rollback;
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
use mro 'c3';
use Sub::Name;
-use Try::Tiny;
-use DBIx::Class::_Util 'sigwarn_silencer';
+use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq );
use namespace::clean;
=head1 NAME
unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) {
require DBD::ADO;
- unless (try { DBD::ADO->VERSION('2.99'); 1 }) {
+ unless ( modver_gt_or_eq( 'DBD::ADO', '2.99' ) ) {
no warnings 'redefine';
my $disconnect = *DBD::ADO::db::disconnect{CODE};
# $sth;
#}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
return $datetime_parser->format_datetime(shift);
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
return @rows;
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+1;
+
# vim:sts=2 sw=2:
L<https://rt.cpan.org/Ticket/Display.html?id=52048>
-The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
+The C<ado_size> workaround is used (see L<DBD::ADO/ADO providers>) 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.
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) = @_;
return $datetime_parser->format_datetime(shift);
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
return @rows;
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+1;
+
# vim:sts=2 sw=2:
throw implicit type conversion errors.
As long as a column L<data_type|DBIx::Class::ResultSource/add_columns> is
-defined and resolves to a base RDBMS native type via L</_native_data_type> 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:
$self->auto_cast(1);
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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 qw( detected_reinvoked_destructor dbic_internal_try );
use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' =>
$self->{_intra_thread} = 1;
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
}
(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 {
sub reset {
$_[0]->__finish_sth if $_[0]->{sth};
$_[0]->sth(undef);
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub DESTROY {
+ return if &detected_reinvoked_destructor;
+
$_[0]->__finish_sth if $_[0]->{sth};
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub __finish_sth {
my $self = shift;
# No need to care about failures here
- try { local $SIG{__WARN__} = sub {}; $self->{sth}->finish } if (
- $self->{sth} and ! try { ! $self->{sth}->FETCH('Active') }
+ dbic_internal_try {
+ local $SIG{__WARN__} = sub {};
+ $self->{sth}->finish
+ } if (
+ $self->{sth}
+ and
+ # weird double-negative to catch the case of ->FETCH throwing
+ # and attempt a finish *anyway*
+ ! dbic_internal_try {
+ ! $self->{sth}->FETCH('Active')
+ }
);
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
+=cut
+
1;
return @res ? $res[0] : undef;
}
-1;
-
=head1 NAME
DBIx::Class::Storage::DBI::DB2 - IBM DB2 support for DBIx::Class
RowNumberOver, queries the server name_sep from L<DBI> and sets the L<DateTime>
parser to L<DateTime::Format::DB2>.
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
# 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
This is an empty subclass of L<DBIx::Class::Storage::DBI::InterBase> for use
with L<DBD::Firebird>, see that driver for details.
-=cut
-
-1;
-
-=head1 AUTHOR
-
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return $date_parser->format_datetime(shift);
}
-1;
-
=head1 CAVEATS
=over 4
=back
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
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 (<<EOS, $bind);
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
return $date_parser->format_datetime(shift);
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
use warnings;
use base qw/DBIx::Class::Storage::DBI::Firebird::Common/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ (dbic_internal_try {
$dbh->do('select 1 from rdb$database');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
# We want dialect 3 for new features and quoting to work, DBD::InterBase uses
$self->_get_dbh->{ib_time_all} = 'ISO';
}
-1;
-
=head1 CAVEATS
=over 4
=back
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use List::Util 'first';
use namespace::clean;
# we didn't even try on ftds
unless ($self->_no_scope_identity_query) {
- ($identity) = try { $sth->fetchrow_array };
+ ($identity) = dbic_internal_try { $sth->fetchrow_array };
$sth->finish;
}
# stored procedures like xp_msver, or version detection failed for some
# other reason.
# So, we use a query to check if RNO is implemented.
- try {
+ dbic_internal_try {
$self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
$supports_rno = 1;
};
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ (dbic_internal_try {
$dbh->do('select 1');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
package # hide from PAUSE
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<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
and
$_[1]
and
- $_[2] !~ /\D/
+ $_[2] !~ /[^0-9]/
and
$_[1] =~ /int(?:eger)? | (?:tiny|small|medium|big)int/ix
);
return $_[2];
}
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
}
}
-1;
-
=head1 NAME
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<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
return $datetime_parser->format_datetime(shift);
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
This is an empty subclass of L<DBIx::Class::Storage::DBI::DB2>.
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-=cut
-# vim:sts=2 sw=2:
/;
use mro 'c3';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
sub _exec_svp_rollback {
my ($self, $name) = @_;
- try {
+ dbic_internal_try {
$self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
catch {
};
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-You may distribute this code under the same terms as Perl itself.
=cut
+
# vim:sts=2 sw=2:
+
+1;
use mro 'c3';
use Scalar::Util 'reftype';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Carp;
use namespace::clean;
!!$self->_using_dynamic_cursors
) {
if ($use_dyncursors) {
- try {
+ dbic_internal_try {
my $dbh = $self->_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$self->_get_dbh->{odbc_SQL_ROWSET_SIZE} = $sql_rowset_size;
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sw=2 sts=2 et
B<WORKAROUND:> use the C<uniqueidentifier> type instead, it is more efficient
anyway.
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-=cut
to your Schema class.
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use DBIx::Class::Carp;
use Scope::Guard ();
use Context::Preserve 'preserve_context';
-use Try::Tiny;
use List::Util 'first';
+use DBIx::Class::_Util qw( modver_gt_or_eq_and_lt dbic_internal_try );
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('RowNum');
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}
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ ( dbic_internal_try {
$dbh->do('select 1 from dual');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
sub _dbh_execute {
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;
}
if ($self->_is_lob_type($dt)) {
- # this is a hot-ish codepath, store an escape-flag in the DBD namespace, so that
- # things like Class::Unload work (unlikely but possible)
- unless ($DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__) {
-
- # no earlier - no later
- if ($DBD::Oracle::VERSION eq '1.23') {
- $self->throw_exception(
- "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
- "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
- );
- }
-
- $DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__ = 1;
- }
+ # no earlier - no later
+ $self->throw_exception(
+ "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later "
+ . "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
+ ) if modver_gt_or_eq_and_lt( 'DBD::Oracle', '1.23', '1.24' );
return {
ora_type => $self->_is_text_lob_type($dt)
the L<DBIx::Class::Relationship> name is shortened and appended with half of an
MD5 hash.
-See L<DBIx::Class::Storage/"relname_to_table_alias">.
+See L<DBIx::Class::Storage::DBI/relname_to_table_alias>.
=cut
# ORDER SIBLINGS BY
# firstname ASC
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
=back
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Justin Wheeler C<< <jwheeler@datademons.com> >>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 CONTRIBUTORS
+=head1 COPYRIGHT AND LICENSE
-David Jack Olrik C<< <djo@cpan.org> >>
-
-=head1 LICENSE
-
-This module is licensed under the same terms as Perl itself.
-
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use Scope::Guard ();
use Context::Preserve 'preserve_context';
use DBIx::Class::Carp;
-use Try::Tiny;
+use DBIx::Class::_Util 'modver_gt_or_eq';
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('LimitOffset');
if ($self->_is_binary_lob_type($data_type)) {
# this is a hot-ish codepath, use an escape flag to minimize
# amount of function/method calls
- # additionally version.pm is cock, and memleaks on multiple
- # ->VERSION calls
# the flag is stored in the DBD namespace, so that Class::Unload
# will work (unlikely, but still)
- unless ($DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__) {
- if ($self->_server_info->{normalized_dbms_version} >= 9.0) {
- try { DBD::Pg->VERSION('2.17.2'); 1 } or carp (
- __PACKAGE__.': BYTEA columns are known to not work on Pg >= 9.0 with DBD::Pg < 2.17.2'
+ unless (
+ modver_gt_or_eq( 'DBD::Pg', '2.17.2' )
+ or
+ $DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__
+ ) {
+ if ( $self->_server_info->{normalized_dbms_version} >= 9.0 ) {
+ $self->throw_exception(
+ 'BYTEA columns are known to not work on Pg >= 9.0 with DBD::Pg < 2.17.2'
);
}
- elsif (not try { DBD::Pg->VERSION('2.9.2'); 1 } ) { carp (
- __PACKAGE__.': DBD::Pg 2.9.2 or greater is strongly recommended for BYTEA column support'
- )}
+ elsif (
+ my $missing = DBIx::Class::Optional::Dependencies->req_missing_for([qw( rdbms_pg binary_data )])
+ ) {
+ # FIXME - perhaps this needs to be an exception too...?
+ # too old to test sensibly...
+ carp (
+ __PACKAGE__ . ": BYTEA column support strongly recommends $missing"
+ )
+ }
$DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__ = 1;
}
},
);
-=head1 AUTHORS
-
-See L<DBIx::Class/CONTRIBUTORS>
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
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;
use List::Util qw/min max reduce/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean -except => 'meta';
-=encoding utf8
-
=head1 NAME
DBIx::Class::Storage::DBI::Replicated - BETA Replicated database support
build_datetime_parser
last_insert_id
insert
- insert_bulk
update
delete
dbh
_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
unimplemented => [qw/
_arm_global_destructor
_verify_pid
+ __delicate_rollback
get_use_dbms_capability
set_use_dbms_capability
set_dbms_capability
_dbh_details
_dbh_get_info
+ _get_rdbms_name
_determine_connector_driver
_extract_driver_from_connect_info
# 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 )
)],
};
=head2 read_handler
-Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
+Defines an object that implements the read side of L<DBIx::Class::Storage::DBI>.
=cut
=head2 write_handler
-Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
+Defines an object that implements the write side of L<DBIx::Class::Storage::DBI>,
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.
=head2 around: connect_replicants
All calls to connect_replicants needs to have an existing $schema tacked onto
-top of the args, since L<DBIx::Storage::DBI> needs it, and any C<connect_info>
+top of the args, since L<DBIx::Class::Storage::DBI> needs it, and any
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>
options merged with the master, with replicant opts having higher priority.
=cut
local $self->{read_handler} = $self->master;
my $args = \@_;
- return try {
+ return dbic_internal_try {
$coderef->(@$args);
} catch {
$self->throw_exception("coderef returned an error: $_");
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.
## $new_schema will use only the Master storage for all reads/writes while
## the $schema object will use replicated storage.
-=head1 AUTHOR
-
- John Napiorkowski <john.napiorkowski@takkle.com>
-
-Based on code originated by:
+=head1 FURTHER QUESTIONS?
- Norbert Csongrádi <bert@cpan.org>
- Peter Siklósi <einon@einon.hu>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
=head2 _build_current_replicant
-Lazy builder for the L</current_replicant_storage> attribute.
+Lazy builder for the L</current_replicant> attribute.
=cut
}
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <jjnapiork@cpan.org>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
return (shift->pool->active_replicants)[0];
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <john.napiorkowski@takkle.com>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
rand($_[1])
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <john.napiorkowski@takkle.com>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
-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<DBIx::Class::Storage::Replication>.
+This is an introductory document for L<DBIx::Class::Storage::DBI::Replicated>.
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<DBIx::Class> supports a framework for using database replication. This system
+L<DBIx::Class> 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.
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).
And now your $schema object is properly configured! Enjoy!
-=head1 AUTHOR
-
-John Napiorkowski <jjnapiork@cpan.org>
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
-1;
use DBI ();
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean -except => 'meta';
sub _safely {
my ($self, $replicant, $name, $code) = @_;
- return try {
+ return dbic_internal_try {
$code->();
1;
} catch {
$self->_last_validated(time);
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <john.napiorkowski@takkle.com>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
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</is_replicating> and L</lag_behind_master>.
+reliability threshold. For that, use
+L<DBIx::Class::Storage::DBI::Replicated/is_replicating> and
+L<DBIx::Class::Storage::DBI::Replicated/lag_behind_master>.
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.
L<http://en.wikipedia.org/wiki/Replicant>,
L<DBIx::Class::Storage::DBI::Replicated>
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <john.napiorkowski@takkle.com>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
where { $_ >= 0 },
message { 'weight must be a decimal greater than 0' };
-# AUTHOR
-#
-# John Napiorkowski <john.napiorkowski@takkle.com>
-#
-# LICENSE
-#
-# You may distribute this code under the same terms as Perl itself.
-
1;
use Scalar::Util 'reftype';
requires qw/_query_start/;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
+
use namespace::clean -except => 'meta';
=head1 NAME
around '_query_start' => sub {
my ($method, $self, $sql, @bind) = @_;
- my $dsn = (try { $self->dsn }) || $self->_dbi_connect_info->[0];
+ my $dsn = (dbic_internal_try { $self->dsn }) || $self->_dbi_connect_info->[0];
my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
if ((reftype($dsn)||'') ne 'CODE') {
"$op [DSN_$storage_type=$dsn]$rest";
}
- elsif (my $id = try { $self->id }) {
+ elsif (my $id = dbic_internal_try { $self->id }) {
"$op [$storage_type=$id]$rest";
}
else {
L<DBIx::Class::Storage::DBI>
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-John Napiorkowski <john.napiorkowski@takkle.com>
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
use List::Util 'first';
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
my $table_name = $source->from;
$table_name = $$table_name if ref $table_name;
- my ($identity) = try {
+ my ($identity) = dbic_internal_try {
$dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
};
sub build_datetime_parser {
my $self = shift;
- my $type = "DateTime::Format::Strptime";
- try {
- eval "require ${type}"
+ dbic_internal_try {
+ 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
Highly recommended.
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return @rows;
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
# vim:sts=2 sw=2:
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
-use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer);
+use SQL::Abstract 'is_plain_value';
+use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer dbic_internal_try);
use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
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<DBIC_RT79576_NOWARN> 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
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__;
- $self->_dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT $name");
+ shift->next::method(@_);
+}
+
+sub _exec_txn_commit {
+ local $SIG{__WARN__} = sigwarn_silencer( qr/commit ineffective/ )
+ unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__;
+
+ shift->next::method(@_);
}
sub _ping {
unless ($DBD::SQLite::__DBIC_TXN_SYNC_SANE__) {
# since we do not have access to sqlite3_get_autocommit(), do a trick
# to attempt to *safely* determine what state are we *actually* in.
- # FIXME
- # also using T::T here leads to bizarre leaks - will figure it out later
- my $really_not_in_txn = do {
- local $@;
+
+ my $really_not_in_txn;
+
+ # not assigning RV directly to env above, because this causes a bizarre
+ # leak of the catch{} cref on older perls... wtf
+ dbic_internal_try {
# older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT
# statements to adjust their {AutoCommit} state. Hence use such a statement
# pair here as well, in order to escape from poking {AutoCommit} needlessly
# https://rt.cpan.org/Public/Bug/Display.html?id=80087
- eval {
- # will fail instantly if already in a txn
- $dbh->do("-- multiline\nBEGIN");
- $dbh->do("-- multiline\nCOMMIT");
- 1;
- } or do {
- ($@ =~ /transaction within a transaction/)
- ? 0
- : undef
- ;
- };
+ #
+ # will fail instantly if already in a txn
+ $dbh->do("-- multiline\nBEGIN");
+ $dbh->do("-- multiline\nCOMMIT");
+
+ $really_not_in_txn = 1;
+ }
+ catch {
+ $really_not_in_txn = ( $_[0] =~ qr/transaction within a transaction/
+ ? 0
+ : undef
+ );
};
# if we were unable to determine this - we may very well be dead
}
# do the actual test and return on no failure
- ( $ping_fail ||= ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } )
+ ( $ping_fail ||= ! dbic_internal_try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } )
or return 1; # the actual RV of _ping()
# ping failed (or so it seems) - need to do some cleanup
# keeps the actual file handle open. We don't really want this to happen,
# so force-close the handle via DBI itself
#
- local $@; # so that we do not clobber the real error as set above
- eval { $dbh->disconnect }; # if it fails - it fails
+ dbic_internal_try { $dbh->disconnect }; # if it fails - it fails
undef; # the actual RV of _ping()
}
$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);
}
= 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
}
}
- 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;
}
);
}
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
use strict;
use warnings;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
=cut
-sub _rebless {
- my $self = shift;
+sub _rebless { shift->_determine_connector_driver('Sybase') }
- 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: $_")
- };
+sub _get_rdbms_name {
+ my $self = shift;
- if ($dbtype) {
- $dbtype =~ s/\W/_/gi;
+ dbic_internal_try {
+ my $name = $self->_get_dbh->selectrow_arrayref('sp_server_info @attribute_id=1')->[2];
- # saner class name
- $dbtype = 'ASE' if $dbtype eq 'SQL_Server';
+ if ($name) {
+ $name =~ s/\W/_/gi;
- 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 {
# FIXME if the main connection goes stale, does opening another for this statement
# really determine anything?
-
+# FIXME (2) THIS MAKES 0 SENSE!!! Need to test later
if ($dbh->{syb_no_child_con}) {
- return try {
+ return dbic_internal_try {
$self->_connect->do('select 1');
1;
}
};
}
- return try {
- $dbh->do('select 1');
- 1;
- }
- catch {
- 0;
- };
+ return (
+ (dbic_internal_try {
+ $dbh->do('select 1');
+ 1;
+ })
+ ? 1
+ : 0
+ );
}
sub _set_max_connect {
return $inf =~ /v([0-9\.]+)/ ? $1 : 0;
}
-1;
+=head1 FURTHER QUESTIONS?
-=head1 AUTHORS
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-See L<DBIx::Class/CONTRIBUTORS>.
+=head1 COPYRIGHT AND LICENSE
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
use Data::Dumper::Concise 'Dumper';
use Try::Tiny;
use Context::Preserve 'preserve_context';
-use DBIx::Class::_Util 'sigwarn_silencer';
+use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try );
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('GenericSubQ');
# 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;
C<1>, but C<0> is better if your database is configured for it.
See
-L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
+L<DBD::Sybase/Handling IMAGE/TEXT data with syb_ct_get_data()/syb_ct_send_data()>.
=cut
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 ];
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.
? 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
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;
}
}
}
-sub insert_bulk {
+sub _insert_bulk {
my $self = shift;
my ($source, $cols, $data) = @_;
# 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(@_);
# 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;
});
my $exception = '';
- try {
+ dbic_internal_try {
my $bulk = $self->_bulk_storage;
my $guard = $bulk->txn_scope_guard;
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
}
else {
$fields->{$col} = \"''";
- $blob_cols{$col} = $blob_val unless $blob_val eq '';
+ $blob_cols{$col} = $blob_val
+ if length $blob_val;
}
}
}
return %blob_cols ? \%blob_cols : undef;
}
-# same for insert_bulk
+# same for _insert_bulk
sub _remove_blob_cols_array {
my ($self, $source, $cols, $data) = @_;
else {
$data->[$j][$i] = \"''";
$blob_cols[$j][$i] = $blob_val
- unless $blob_val eq '';
+ if length $blob_val;
}
}
}
sub _update_blobs {
my ($self, $source, $blob_cols, $where) = @_;
- my @primary_cols = try
+ my @primary_cols = dbic_internal_try
{ $source->_pri_cols_or_die }
catch {
$self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
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};
}
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
+ my @primary_cols = dbic_internal_try
{ $source->_pri_cols_or_die }
catch {
$self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
};
$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;
);
}
- try {
+ dbic_internal_try {
do {
$sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
} while $sth->fetch;
=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<GenericSubQ|SQL::Abstract::Limit/GenericSubQ>.
+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<GenericSubQ|DBIx::Class::SQLMaker::LimitDialects/GenericSubQ>.
Fortunately, ASE and L<DBD::Sybase> support cursors properly, so when
-L<GenericSubQ|SQL::Abstract::Limit/GenericSubQ> is too slow you can use
-the L<software_limit|DBIx::Class::ResultSet/software_limit>
-L<DBIx::Class::ResultSet> attribute to simulate limited queries by skipping over
-records.
+L<GenericSubQ|DBIx::Class::SQLMaker::LimitDialects/GenericSubQ> is too slow
+you can use the L<software_limit|DBIx::Class::ResultSet/software_limit>
+L<DBIx::Class::ResultSet> attribute to simulate limited queries by skipping
+over records.
=head1 TEXT/IMAGE COLUMNS
B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
calls in your C<Result> classes B<must> list columns in database order for this
-to work. Also, you may have to unset the C<LANG> environment variable before
+to work. Also, you may have to unset the C<LC_ALL> environment variable before
loading your app, as C<BCP -Y> is not yet supported in DBD::Sybase .
When inserting IMAGE columns using this method, you'll need to use
=back
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
$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<select @@identity> will work
for obtaining the last insert id of an C<IDENTITY> column, instead of having to
The caching of prepared statements is also explicitly disabled, as the
interpolation renders it useless.
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use warnings;
use base qw/DBIx::Class::Storage::DBI::Sybase/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
my $text_size =
shift
||
- try { $self->_dbic_cinnect_attributes->{LongReadLen} }
+ dbic_internal_try { $self->_dbic_connect_attributes->{LongReadLen} }
||
32768; # the DBD::Sybase default
$dbh->do('ROLLBACK');
}
-1;
-
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
$schema->storage_type('::DBI::Sybase::MSSQL');
$schema->connect_info('dbi:Sybase:....', ...);
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return $datetime_formatter->format_datetime(shift);
}
-1;
-
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
+
In all other respects, it is a subclass of
L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=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<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return $self->next::method(@_);
}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
return $self->next::method(@_) if ( $_[0] eq 'select' or $_[0] eq 'insert' );
- # FIXME FIXME FIXME - this is a terrible, gross, incomplete hack
- # it should be trivial for mst to port this to DQ (and a good
- # exercise as well, since we do not yet have such wide tree walking
- # in place). For the time being this will work in limited cases,
- # mainly complex update/delete, which is really all we want it for
- # currently (allows us to fix some bugs without breaking MySQL in
- # the process, and is also crucial for Shadow to be usable)
+ # FIXME FIXME FIXME - this is a terrible, gross, incomplete, MySQL-specific
+ # hack but it works rather well for the limited amount of actual use cases
+ # which can not be done in any other way on MySQL. This allows us to fix
+ # some bugs without breaking MySQL support in the process and is also
+ # crucial for more complex things like Shadow to be usable
+ #
+ # This code is just a pre-analyzer, working in tandem with ::SQLMaker::MySQL,
+ # where the possibly-set value of {_modification_target_referenced_re} is
+ # used to demarcate which part of the final SQL to double-wrap in a subquery.
+ #
+ # This is covered extensively by "offline" tests, so when the DQ work
+ # resumes, this will get flagged. Afaik there are no AST-visitor code of that
+ # magnitude yet (Oct 2015) within DQ, so a good exercise overall.
# extract the source name, construct modification indicator re
my $sm = $self->sql_maker;
sub sql_maker {
my $self = shift;
- unless ($self->_sql_maker) {
- my $maker = $self->next::method (@_);
+ # it is critical to get the version *before* calling next::method
+ # otherwise the potential connect will obliterate the sql_maker
+ # next::method will populate in the _sql_maker accessor
+ my $mysql_ver = $self->_server_info->{normalized_dbms_version};
- # mysql 3 does not understand a bare JOIN
- my $mysql_ver = $self->_dbh_get_info('SQL_DBMS_VER');
- $maker->{_default_jointype} = 'INNER' if $mysql_ver =~ /^3/;
- }
+ my $sm = $self->next::method(@_);
+
+ # mysql 3 does not understand a bare JOIN
+ $sm->{_default_jointype} = 'INNER' if $mysql_ver < 4;
- return $self->_sql_maker;
+ $sm;
}
sub sqlt_type {
]
});
-=head1 AUTHORS
-
-See L<DBIx::Class/CONTRIBUTORS>
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
DBIx::Class::Storage::DBIHacks;
#
-# This module contains code that should never have seen the light of day,
-# does not belong in the Storage, or is otherwise unfit for public
-# display. The arrival of SQLA2 should immediately obsolete 90% of this
+# This module contains code supporting a battery of special cases and tests for
+# many corner cases pushing the envelope of what DBIC can do. When work on
+# these utilities began in mid 2009 (51a296b402c) it wasn't immediately obvious
+# that these pieces, despite their misleading on-first-sighe-flakiness, will
+# become part of the generic query rewriting machinery of DBIC, allowing it to
+# both generate and process queries representing incredibly complex sets with
+# reasonable efficiency.
+#
+# Now (end of 2015), more than 6 years later the routines in this class have
+# stabilized enough, and are meticulously covered with tests, to a point where
+# an effort to formalize them into user-facing APIs might be worthwhile.
+#
+# An implementor working on publicizing and/or replacing the routines with a
+# more modern SQL generation framework should keep in mind that pretty much all
+# existing tests are constructed on the basis of real-world code used in
+# production somewhere.
+#
+# Please hack on this responsibly ;)
#
use strict;
use List::Util 'first';
use Scalar::Util 'blessed';
-use Sub::Name 'subname';
+use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize);
+use SQL::Abstract qw(is_plain_value is_literal_value);
+use DBIx::Class::Carp;
use namespace::clean;
#
$self->_use_join_optimizer
);
- my $orig_aliastypes = $self->_resolve_aliastypes_from_select_args($attrs);
+ my $orig_aliastypes =
+ $attrs->{_precalculated_aliastypes}
+ ||
+ $self->_resolve_aliastypes_from_select_args($attrs)
+ ;
my $new_aliastypes = { %$orig_aliastypes };
my $outer_attrs = { %$attrs };
delete @{$outer_attrs}{qw(from bind rows offset group_by _grouped_by_distinct having)};
- my $inner_attrs = { %$attrs };
- delete @{$inner_attrs}{qw(for collapse select as _related_results_construction)};
+ my $inner_attrs = { %$attrs, _simple_passthrough_construction => 1 };
+ delete @{$inner_attrs}{qw(for collapse select as)};
# there is no point of ordering the insides if there is no limit
delete $inner_attrs->{order_by} if (
push @{$inner_attrs->{as}}, $attrs->{as}[$i];
}
- # We will need to fetch all native columns in the inner subquery, which may
+ my $inner_aliastypes = $self->_resolve_aliastypes_from_select_args($inner_attrs);
+
+ # In the inner subq we will need to fetch *only* native columns which may
# be a part of an *outer* join condition, or an order_by (which needs to be
# preserved outside), or wheres. In other words everything but the inner
# selector
# We can not just fetch everything because a potential has_many restricting
# join collapse *will not work* on heavy data types.
- my $connecting_aliastypes = $self->_resolve_aliastypes_from_select_args({
- %$inner_attrs,
- select => [],
- });
- for (sort map { keys %{$_->{-seen_columns}||{}} } map { values %$_ } values %$connecting_aliastypes) {
+ # essentially a map of all non-selecting seen columns
+ # the sort is there for a nicer select list
+ for (
+ sort
+ map
+ { keys %{$_->{-seen_columns}||{}} }
+ map
+ { values %{$inner_aliastypes->{$_}} }
+ grep
+ { $_ ne 'selecting' }
+ keys %$inner_aliastypes
+ ) {
my $ci = $colinfo->{$_} or next;
if (
$ci->{-source_alias} eq $root_alias
local $self->{_use_join_optimizer} = 1;
# throw away multijoins since we def. do not care about those inside the subquery
- ($inner_attrs->{from}, my $inner_aliastypes) = $self->_prune_unused_joins ({
- %$inner_attrs, _force_prune_multiplying_joins => 1
+ # $inner_aliastypes *will* be redefined at this point
+ ($inner_attrs->{from}, $inner_aliastypes ) = $self->_prune_unused_joins ({
+ %$inner_attrs,
+ _force_prune_multiplying_joins => 1,
+ _precalculated_aliastypes => $inner_aliastypes,
});
# uh-oh a multiplier (which is not us) left in, this is a problem for limits
});
}
- # This is totally horrific - the {where} ends up in both the inner and outer query
- # Unfortunately not much can be done until SQLA2 introspection arrives, and even
- # then if where conditions apply to the *right* side of the prefetch, you may have
- # to both filter the inner select (e.g. to apply a limit) and then have to re-filter
- # the outer select to exclude joins you didn't want in the first place
+ # FIXME: The {where} ends up in both the inner and outer query, i.e. *twice*
+ #
+ # This is rather horrific, and while we currently *do* have enough
+ # introspection tooling available to attempt a stab at properly deciding
+ # whether or not to include the where condition on the outside, the
+ # machinery is still too slow to apply it here.
+ # Thus for the time being we do not attempt any sanitation of the where
+ # clause and just pass it through on both sides of the subquery. This *will*
+ # be addressed at a later stage, most likely after folding the SQL generator
+ # into SQLMaker proper
#
# OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;)
+ #
return $outer_attrs;
}
+# This is probably the ickiest, yet most relied upon part of the codebase:
+# this is the place where we take arbitrary SQL input and break it into its
+# constituent parts, making sure we know which *sources* are used in what
+# *capacity* ( selecting / restricting / grouping / ordering / joining, etc )
+# Although the method is pretty horrific, the worst thing that can happen is
+# for a classification failure, which in turn will result in a vocal exception,
+# and will lead to a relatively prompt fix.
+# The code has been slowly improving and is covered with a formiddable battery
+# of tests, so can be considered "reliably stable" at this point (Oct 2015).
+#
+# A note to implementors attempting to "replace" this - keep in mind that while
+# there are multiple optimization avenues, the actual "scan literal elements"
+# part *MAY NEVER BE REMOVED*, even if it is limited only ot the (future) AST
+# nodes that are deemed opaque (i.e. contain literal expressions). The use of
+# blackbox literals is at this point firmly a user-facing API, and is one of
+# *the* reasons DBIC remains as flexible as it is. In other words, when working
+# on this keep in mind that the following is widespread and *encouraged* way
+# of using DBIC in the wild when push comes to shove:
#
-# I KNOW THIS SUCKS! GET SQLA2 OUT THE DOOR SO THIS CAN DIE!
+# $rs->search( {}, {
+# select => \[ $random, @stuff],
+# from => \[ $random, @stuff ],
+# where => \[ $random, @stuff ],
+# group_by => \[ $random, @stuff ],
+# order_by => \[ $random, @stuff ],
+# } )
+#
+# Various incarnations of the above are reflected in many of the tests. If one
+# gets to fail, you get to fix it. A "this is crazy, nobody does that" is not
+# acceptable going forward.
#
-# Due to a lack of SQLA2 we fall back to crude scans of all the
-# select/where/order/group attributes, in order to determine what
-# aliases are needed to fulfill the query. This information is used
-# throughout the code to prune unnecessary JOINs from the queries
-# in an attempt to reduce the execution time.
-# Although the method is pretty horrific, the worst thing that can
-# happen is for it to fail due to some scalar SQL, which in turn will
-# result in a vocal exception.
sub _resolve_aliastypes_from_select_args {
my ( $self, $attrs ) = @_;
my $sql_maker = $self->sql_maker;
# these are throw away results, do not pollute the bind stack
- local $sql_maker->{select_bind};
local $sql_maker->{where_bind};
local $sql_maker->{group_bind};
local $sql_maker->{having_bind};
# generate sql chunks
my $to_scan = {
restricting => [
- $sql_maker->_recurse_where ($attrs->{where}),
+ ($sql_maker->_recurse_where ($attrs->{where}))[0],
$sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }),
],
grouping => [
),
],
selecting => [
- map { $sql_maker->_recurse_fields($_) } @{$attrs->{select}},
+ # kill all selectors which look like a proper subquery
+ # this is a sucky heuristic *BUT* - if we get it wrong the query will simply
+ # fail to run, so we are relatively safe
+ grep
+ { $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi }
+ map
+ { ($sql_maker->_recurse_fields($_))[0] }
+ @{$attrs->{select}}
],
- ordering => [
- map { $_->[0] } $self->_extract_order_criteria ($attrs->{order_by}, $sql_maker),
+ ordering => [ map
+ {
+ ( my $sql = (ref $_ ? $_->[0] : $_) ) =~ s/ \s+ (?: ASC | DESC ) \s* \z //xi;
+ $sql;
+ }
+ $sql_maker->_order_by_chunks( $attrs->{order_by} ),
],
};
- # throw away empty chunks and all 2-value arrayrefs: the thinking is that these are
- # bind value specs left in by the sloppy renderer above. It is ok to do this
- # at this point, since we are going to end up rewriting this crap anyway
- for my $v (values %$to_scan) {
- my @nv;
- for (@$v) {
- next if (
- ! defined $_
- or
- (
- ref $_ eq 'ARRAY'
- and
- ( @$_ == 0 or @$_ == 2 )
- )
- );
+ # we will be bulk-scanning anyway - pieces will not matter in that case,
+ # thus join everything up
+ # throw away empty-string chunks, and make sure no binds snuck in
+ # note that we operate over @{$to_scan->{$type}}, hence the
+ # semi-mindbending ... map ... for values ...
+ ( $_ = join ' ', map {
+
+ ( ! defined $_ ) ? ()
+ : ( length ref $_ ) ? (require Data::Dumper::Concise && $self->throw_exception(
+ "Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($_)
+ ))
+ : ( $_ =~ /^\s*$/ ) ? ()
+ : $_
+
+ } @$_ ) for values %$to_scan;
+
+ # throw away empty to-scan's
+ (
+ length $to_scan->{$_}
+ or
+ delete $to_scan->{$_}
+ ) for keys %$to_scan;
- if (ref $_) {
- require Data::Dumper::Concise;
- $self->throw_exception("Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($v) );
- }
- push @nv, $_;
- }
- $v = \@nv;
- }
+ # these will be used for matching in the loop below
+ my $all_aliases = join ' | ', map { quotemeta $_ } keys %$alias_list;
+ my $fq_col_re = qr/
+ $lquote ( $all_aliases ) $rquote $sep (?: $lquote ([^$rquote]+) $rquote )?
+ |
+ \b ( $all_aliases ) \. ( [^\s\)\($rquote]+ )?
+ /x;
- # kill all selectors which look like a proper subquery
- # this is a sucky heuristic *BUT* - if we get it wrong the query will simply
- # fail to run, so we are relatively safe
- $to_scan->{selecting} = [ grep {
- $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi
- } @{ $to_scan->{selecting} || [] } ];
- # first see if we have any exact matches (qualified or unqualified)
+ my $all_unq_columns = join ' | ',
+ map
+ { quotemeta $_ }
+ grep
+ # using a regex here shows up on profiles, boggle
+ { index( $_, '.') < 0 }
+ keys %$colinfo
+ ;
+ my $unq_col_re = $all_unq_columns
+ ? qr/
+ $lquote ( $all_unq_columns ) $rquote
+ |
+ (?: \A | \s ) ( $all_unq_columns ) (?: \s | \z )
+ /x
+ : undef
+ ;
+
+
+ # the actual scan, per type
for my $type (keys %$to_scan) {
- for my $piece (@{$to_scan->{$type}}) {
- if ($colinfo->{$piece} and my $alias = $colinfo->{$piece}{-source_alias}) {
- $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] };
- $aliases_by_type->{$type}{$alias}{-seen_columns}{$colinfo->{$piece}{-fq_colname}} = $piece;
- }
- }
- }
- # now loop through all fully qualified columns and get the corresponding
- # alias (should work even if they are in scalarrefs)
- for my $alias (keys %$alias_list) {
- my $al_re = qr/
- $lquote $alias $rquote $sep (?: $lquote ([^$rquote]+) $rquote )?
- |
- \b $alias \. ([^\s\)\($rquote]+)?
- /x;
-
- for my $type (keys %$to_scan) {
- for my $piece (@{$to_scan->{$type}}) {
- if (my @matches = $piece =~ /$al_re/g) {
- $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] };
- $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = "$alias.$_"
- for grep { defined $_ } @matches;
- }
+
+ # now loop through all fully qualified columns and get the corresponding
+ # alias (should work even if they are in scalarrefs)
+ #
+ # The regex captures in multiples of 4, with one of the two pairs being
+ # undef. There may be a *lot* of matches, hence the convoluted loop
+ my @matches = $to_scan->{$type} =~ /$fq_col_re/g;
+ my $i = 0;
+ while( $i < $#matches ) {
+
+ if (
+ defined $matches[$i]
+ ) {
+ $aliases_by_type->{$type}{$matches[$i]} ||= { -parents => $alias_list->{$matches[$i]}{-join_path}||[] };
+
+ $aliases_by_type->{$type}{$matches[$i]}{-seen_columns}{"$matches[$i].$matches[$i+1]"} = "$matches[$i].$matches[$i+1]"
+ if defined $matches[$i+1];
+
+ $i += 2;
}
+
+ $i += 2;
}
- }
- # now loop through unqualified column names, and try to locate them within
- # the chunks
- for my $col (keys %$colinfo) {
- next if $col =~ / \. /x; # if column is qualified it was caught by the above
- my $col_re = qr/ $lquote ($col) $rquote /x;
+ # now loop through unqualified column names, and try to locate them within
+ # the chunks, if there are any unqualified columns in the 1st place
+ next unless $unq_col_re;
- for my $type (keys %$to_scan) {
- for my $piece (@{$to_scan->{$type}}) {
- if ( my @matches = $piece =~ /$col_re/g) {
- my $alias = $colinfo->{$col}{-source_alias};
- $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] };
- $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = $_
- for grep { defined $_ } @matches;
- }
- }
+ # The regex captures in multiples of 2, one of the two being undef
+ for ( $to_scan->{$type} =~ /$unq_col_re/g ) {
+ defined $_ or next;
+ my $alias = $colinfo->{$_}{-source_alias} or next;
+ $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] };
+ $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = $_
}
}
+
# Add any non-left joins to the restriction list (such joins are indeed restrictions)
- for my $j (values %$alias_list) {
- my $alias = $j->{-alias} or next;
- $aliases_by_type->{restricting}{$alias} ||= { -parents => $j->{-join_path}||[] } if (
- (not $j->{-join_type})
+ (
+ $_->{-alias}
+ and
+ ! $aliases_by_type->{restricting}{ $_->{-alias} }
+ and
+ (
+ not $_->{-join_type}
or
- ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
- );
- }
+ $_->{-join_type} !~ /^left (?: \s+ outer)? $/xi
+ )
+ and
+ $aliases_by_type->{restricting}{ $_->{-alias} } = { -parents => $_->{-join_path}||[] }
+ ) for values %$alias_list;
- for (keys %$aliases_by_type) {
- delete $aliases_by_type->{$_} unless keys %{$aliases_by_type->{$_}};
- }
- return $aliases_by_type;
+ # final cleanup
+ (
+ keys %{$aliases_by_type->{$_}}
+ or
+ delete $aliases_by_type->{$_}
+ ) for keys %$aliases_by_type;
+
+
+ $aliases_by_type;
}
# This is the engine behind { distinct => 1 } and the general
# of the external order and convert them to MIN(X) for ASC or MAX(X)
# for DESC, and group_by the root columns. The end result should be
# exactly what we expect
-
- # FIXME - this code is a joke, will need to be completely rewritten in
- # the DQ branch. But I need to push a POC here, otherwise the
- # pesky tests won't pass
- # wrap any part of the order_by that "responds" to an ordering alias
- # into a MIN/MAX
+ #
$sql_maker ||= $self->sql_maker;
$order_chunks ||= [
map { ref $_ eq 'ARRAY' ? $_ : [ $_ ] } $sql_maker->_order_by_chunks($attrs->{order_by})
my ($chunk, $is_desc) = $sql_maker->_split_order_chunk($order_chunks->[$o_idx][0]);
+ # we reached that far - wrap any part of the order_by that "responded"
+ # to an ordering alias into a MIN/MAX
$new_order_by[$o_idx] = \[
sprintf( '%s( %s )%s',
($is_desc ? 'MAX' : 'MIN'),
}
$self->throw_exception ( sprintf
- 'A required group_by clause could not be constructed automatically due to a complex '
- . 'order_by criteria (%s). Either order_by columns only (no functions) or construct a suitable '
- . 'group_by by hand',
+ 'Unable to programatically derive a required group_by from the supplied '
+ . 'order_by criteria. To proceed either add an explicit group_by, or '
+ . 'simplify your order_by to only include plain columns '
+ . '(supplied order_by: %s)',
join ', ', map { "'$_'" } @$leftovers,
) if $leftovers;
# for all sources
sub _resolve_column_info {
my ($self, $ident, $colnames) = @_;
- my $alias2src = $self->_resolve_ident_sources($ident);
+
+ return {} if $colnames and ! @$colnames;
+
+ my $sources = $self->_resolve_ident_sources($ident);
+
+ $_ = { rsrc => $_, colinfos => $_->columns_info }
+ for values %$sources;
my (%seen_cols, @auto_colnames);
# compile a global list of column names, to be able to properly
# disambiguate unqualified column names (if at all possible)
- for my $alias (keys %$alias2src) {
- my $rsrc = $alias2src->{$alias};
- for my $colname ($rsrc->columns) {
- push @{$seen_cols{$colname}}, $alias;
- push @auto_colnames, "$alias.$colname" unless $colnames;
- }
+ for my $alias (keys %$sources) {
+ (
+ ++$seen_cols{$_}{$alias}
+ and
+ ! $colnames
+ and
+ push @auto_colnames, "$alias.$_"
+ ) for keys %{ $sources->{$alias}{colinfos} };
}
$colnames ||= [
@auto_colnames,
- grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols),
+ ( grep { keys %{$seen_cols{$_}} == 1 } keys %seen_cols ),
];
- my (%return, $colinfos);
- foreach my $col (@$colnames) {
- my ($source_alias, $colname) = $col =~ m/^ (?: ([^\.]+) \. )? (.+) $/x;
-
- # if the column was seen exactly once - we know which rsrc it came from
- $source_alias ||= $seen_cols{$colname}[0]
- if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1);
+ my %return;
+ for (@$colnames) {
+ my ($colname, $source_alias) = reverse split /\./, $_;
- next unless $source_alias;
+ my $assumed_alias =
+ $source_alias
+ ||
+ # if the column was seen exactly once - we know which rsrc it came from
+ (
+ $seen_cols{$colname}
+ and
+ keys %{$seen_cols{$colname}} == 1
+ and
+ ( %{$seen_cols{$colname}} )[0]
+ )
+ ||
+ next
+ ;
- my $rsrc = $alias2src->{$source_alias}
- or next;
+ $self->throw_exception(
+ "No such column '$colname' on source " . $sources->{$assumed_alias}{rsrc}->source_name
+ ) unless $seen_cols{$colname}{$assumed_alias};
- $return{$col} = {
- %{
- ( $colinfos->{$source_alias} ||= $rsrc->columns_info )->{$colname}
- ||
- $self->throw_exception(
- "No such column '$colname' on source " . $rsrc->source_name
- );
- },
- -result_source => $rsrc,
- -source_alias => $source_alias,
- -fq_colname => $col eq $colname ? "$source_alias.$col" : $col,
+ $return{$_} = {
+ %{ $sources->{$assumed_alias}{colinfos}{$colname} },
+ -result_source => $sources->{$assumed_alias}{rsrc},
+ -source_alias => $assumed_alias,
+ -fq_colname => "$assumed_alias.$colname",
-colname => $colname,
};
- $return{"$source_alias.$colname"} = $return{$col} if $col eq $colname;
+ $return{"$assumed_alias.$colname"} = $return{$_}
+ unless $source_alias;
}
return \%return;
sub _inner_join_to_node {
my ($self, $from, $alias) = @_;
- # subqueries and other oddness are naturally not supported
- return $from if (
- ref $from ne 'ARRAY'
- ||
- @$from <= 1
- ||
- ref $from->[0] ne 'HASH'
- ||
- ! $from->[0]{-alias}
- ||
- $from->[0]{-alias} eq $alias # this last bit means $alias is the head of $from - nothing to do
- );
+ my $switch_branch = $self->_find_join_path_to_node($from, $alias);
- # find the current $alias in the $from structure
- my $switch_branch;
- JOINSCAN:
- for my $j (@{$from}[1 .. $#$from]) {
- if ($j->[0]{-alias} eq $alias) {
- $switch_branch = $j->[0]{-join_path};
- last JOINSCAN;
- }
- }
-
- # something else went quite wrong
- return $from unless $switch_branch;
+ return $from unless @{$switch_branch||[]};
# So it looks like we will have to switch some stuff around.
# local() is useless here as we will be leaving the scope
return \@new_from;
}
+sub _find_join_path_to_node {
+ my ($self, $from, $target_alias) = @_;
+
+ # subqueries and other oddness are naturally not supported
+ return undef if (
+ ref $from ne 'ARRAY'
+ ||
+ ref $from->[0] ne 'HASH'
+ ||
+ ! defined $from->[0]{-alias}
+ );
+
+ # no path - the head is the alias
+ return [] if $from->[0]{-alias} eq $target_alias;
+
+ for my $i (1 .. $#$from) {
+ return $from->[$i][0]{-join_path} if ( ($from->[$i][0]{-alias}||'') eq $target_alias );
+ }
+
+ # something else went quite wrong
+ return undef;
+}
+
sub _extract_order_criteria {
my ($self, $order_by, $sql_maker) = @_;
my ($self, $ident, $order_by, $where) = @_;
my @cols = (
- (map { $_->[0] } $self->_extract_order_criteria($order_by)),
- $where ? @{$self->_extract_fixed_condition_columns($where)} :(),
- ) or return undef;
+ ( map { $_->[0] } $self->_extract_order_criteria($order_by) ),
+ ( $where ? keys %{ $self->_extract_fixed_condition_columns($where) } : () ),
+ ) or return 0;
my $colinfo = $self->_resolve_column_info($ident, \@cols);
return keys %$colinfo
? $self->_columns_comprise_identifying_set( $colinfo, \@cols )
- : undef
+ : 0
;
}
return 1 if $src->_identifying_column_set($_);
}
- return undef;
+ return 0;
}
-# this is almost identical to the above, except it accepts only
+# this is almost similar to _order_by_is_stable, except it takes
# a single rsrc, and will succeed only if the first portion of the order
# by is stable.
# returns that portion as a colinfo hashref on success
-sub _main_source_order_by_portion_is_stable {
- my ($self, $main_rsrc, $order_by, $where) = @_;
+sub _extract_colinfo_of_stable_main_source_order_by_portion {
+ my ($self, $attrs) = @_;
+
+ my $nodes = $self->_find_join_path_to_node($attrs->{from}, $attrs->{alias});
- die "Huh... I expect a blessed result_source..."
- if ref($main_rsrc) eq 'ARRAY';
+ return unless defined $nodes;
my @ord_cols = map
{ $_->[0] }
- ( $self->_extract_order_criteria($order_by) )
+ ( $self->_extract_order_criteria($attrs->{order_by}) )
;
return unless @ord_cols;
- my $colinfos = $self->_resolve_column_info($main_rsrc);
+ my $valid_aliases = { map { $_ => 1 } (
+ $attrs->{from}[0]{-alias},
+ map { values %$_ } @$nodes,
+ ) };
+
+ my $colinfos = $self->_resolve_column_info($attrs->{from});
+
+ my ($colinfos_to_return, $seen_main_src_cols);
+
+ for my $col (@ord_cols) {
+ # if order criteria is unresolvable - there is nothing we can do
+ my $colinfo = $colinfos->{$col} or last;
+
+ # if we reached the end of the allowed aliases - also nothing we can do
+ last unless $valid_aliases->{$colinfo->{-source_alias}};
+
+ $colinfos_to_return->{$col} = $colinfo;
- for (0 .. $#ord_cols) {
+ $seen_main_src_cols->{$colinfo->{-colname}} = 1
+ if $colinfo->{-source_alias} eq $attrs->{alias};
+ }
+
+ # FIXME the condition may be singling out things on its own, so we
+ # conceivable could come back wi "stable-ordered by nothing"
+ # not confient enough in the parser yet, so punt for the time being
+ return unless $seen_main_src_cols;
+
+ my $main_src_fixed_cols_from_cond = [ $attrs->{where}
+ ? (
+ map
+ {
+ ( $colinfos->{$_} and $colinfos->{$_}{-source_alias} eq $attrs->{alias} )
+ ? $colinfos->{$_}{-colname}
+ : ()
+ }
+ keys %{ $self->_extract_fixed_condition_columns($attrs->{where}) }
+ )
+ : ()
+ ];
+
+ return $attrs->{result_source}->_identifying_column_set([
+ keys %$seen_main_src_cols,
+ @$main_src_fixed_cols_from_cond,
+ ]) ? $colinfos_to_return : ();
+}
+
+# Attempts to flatten a passed in SQLA condition as much as possible towards
+# a plain hashref, *without* altering its semantics. Required by
+# create/populate being able to extract definitive conditions from preexisting
+# resultset {where} stacks
+#
+# FIXME - while relatively robust, this is still imperfect, one of the first
+# things to tackle when we get access to a formalized AST. Note that this code
+# is covered by a *ridiculous* amount of tests, so starting with porting this
+# code would be a rather good exercise
+sub _collapse_cond {
+ my ($self, $where, $where_is_anded_array) = @_;
+
+ my $fin;
+
+ if (! $where) {
+ return;
+ }
+ elsif ($where_is_anded_array or ref $where eq 'HASH') {
+
+ my @pairs;
+
+ my @pieces = $where_is_anded_array ? @$where : $where;
+ while (@pieces) {
+ my $chunk = shift @pieces;
+
+ if (ref $chunk eq 'HASH') {
+ for (sort keys %$chunk) {
+
+ # Match SQLA 1.79 behavior
+ unless( length $_ ) {
+ is_literal_value($chunk->{$_})
+ ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead'
+ : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs")
+ ;
+ }
+
+ push @pairs, $_ => $chunk->{$_};
+ }
+ }
+ elsif (ref $chunk eq 'ARRAY') {
+ push @pairs, -or => $chunk
+ if @$chunk;
+ }
+ elsif ( ! length ref $chunk) {
+
+ # Match SQLA 1.79 behavior
+ $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs")
+ if $where_is_anded_array and (! defined $chunk or ! length $chunk);
+
+ push @pairs, $chunk, shift @pieces;
+ }
+ else {
+ push @pairs, '', $chunk;
+ }
+ }
+
+ return unless @pairs;
+
+ my @conds = $self->_collapse_cond_unroll_pairs(\@pairs)
+ or return;
+
+ # Consolidate various @conds back into something more compact
+ for my $c (@conds) {
+ if (ref $c ne 'HASH') {
+ push @{$fin->{-and}}, $c;
+ }
+ else {
+ for my $col (sort keys %$c) {
+
+ # consolidate all -and nodes
+ if ($col =~ /^\-and$/i) {
+ push @{$fin->{-and}},
+ ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}}
+ : ref $c->{$col} eq 'HASH' ? %{$c->{$col}}
+ : { $col => $c->{$col} }
+ ;
+ }
+ elsif ($col =~ /^\-/) {
+ push @{$fin->{-and}}, { $col => $c->{$col} };
+ }
+ elsif (exists $fin->{$col}) {
+ $fin->{$col} = [ -and => map {
+ (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i )
+ ? @{$_}[1..$#$_]
+ : $_
+ ;
+ } ($fin->{$col}, $c->{$col}) ];
+ }
+ else {
+ $fin->{$col} = $c->{$col};
+ }
+ }
+ }
+ }
+ }
+ elsif (ref $where eq 'ARRAY') {
+ # we are always at top-level here, it is safe to dump empty *standalone* pieces
+ my $fin_idx;
+
+ for (my $i = 0; $i <= $#$where; $i++ ) {
+
+ # Match SQLA 1.79 behavior
+ $self->throw_exception(
+ "Supplying an empty left hand side argument is not supported in array-pairs"
+ ) if (! defined $where->[$i] or ! length $where->[$i]);
+
+ my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' );
+
+ if ($logic_mod) {
+ $i++;
+ $self->throw_exception("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]")
+ unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY';
+
+ my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] })
+ or next;
+
+ my @keys = keys %$sub_elt;
+ if ( @keys == 1 and $keys[0] !~ /^\-/ ) {
+ $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt;
+ }
+ else {
+ $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt;
+ }
+ }
+ elsif (! length ref $where->[$i] ) {
+ my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] })
+ or next;
+
+ $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt;
+ $i++;
+ }
+ else {
+ $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next;
+ }
+ }
+
+ if (! $fin_idx) {
+ return;
+ }
+ elsif ( keys %$fin_idx == 1 ) {
+ $fin = (values %$fin_idx)[0];
+ }
+ else {
+ my @or;
+
+ # at this point everything is at most one level deep - unroll if needed
+ for (sort keys %$fin_idx) {
+ if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) {
+ my ($l, $r) = %{$fin_idx->{$_}};
+
+ if (
+ ref $r eq 'ARRAY'
+ and
+ (
+ ( @$r == 1 and $l =~ /^\-and$/i )
+ or
+ $l =~ /^\-or$/i
+ )
+ ) {
+ push @or, @$r
+ }
+
+ elsif (
+ ref $r eq 'HASH'
+ and
+ keys %$r == 1
+ and
+ $l =~ /^\-(?:and|or)$/i
+ ) {
+ push @or, %$r;
+ }
+
+ else {
+ push @or, $l, $r;
+ }
+ }
+ else {
+ push @or, $fin_idx->{$_};
+ }
+ }
+
+ $fin->{-or} = \@or;
+ }
+ }
+ else {
+ # not a hash not an array
+ $fin = { -and => [ $where ] };
+ }
+
+ # unroll single-element -and's
+ while (
+ $fin->{-and}
+ and
+ @{$fin->{-and}} < 2
+ ) {
+ my $and = delete $fin->{-and};
+ last if @$and == 0;
+
+ # at this point we have @$and == 1
if (
- ! $colinfos->{$ord_cols[$_]}
- or
- $colinfos->{$ord_cols[$_]}{-result_source} != $main_rsrc
+ ref $and->[0] eq 'HASH'
+ and
+ ! grep { exists $fin->{$_} } keys %{$and->[0]}
) {
- $#ord_cols = $_ - 1;
+ $fin = {
+ %$fin, %{$and->[0]}
+ };
+ }
+ else {
+ $fin->{-and} = $and;
last;
}
}
- # we just truncated it above
- return unless @ord_cols;
+ # compress same-column conds found in $fin
+ for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) {
+ next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i;
+ my $val_bag = { map {
+ (! defined $_ ) ? ( UNDEF => undef )
+ : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ )
+ : ( ( 'SER_' . serialize $_ ) => $_ )
+ } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] };
+
+ if (keys %$val_bag == 1 ) {
+ ($fin->{$col}) = values %$val_bag;
+ }
+ else {
+ $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ];
+ }
+ }
- my $order_portion_ci = { map {
- $colinfos->{$_}{-colname} => $colinfos->{$_},
- $colinfos->{$_}{-fq_colname} => $colinfos->{$_},
- } @ord_cols };
+ return keys %$fin ? $fin : ();
+}
- # since all we check here are the start of the order_by belonging to the
- # top level $rsrc, a present identifying set will mean that the resultset
- # is ordered by its leftmost table in a stable manner
- #
- # RV of _identifying_column_set contains unqualified names only
- my $unqualified_idset = $main_rsrc->_identifying_column_set({
- ( $where ? %{
- $self->_resolve_column_info(
- $main_rsrc, $self->_extract_fixed_condition_columns($where)
- )
- } : () ),
- %$order_portion_ci
- }) or return;
+sub _collapse_cond_unroll_pairs {
+ my ($self, $pairs) = @_;
- my $ret_info;
- my %unqualified_idcols_from_order = map {
- $order_portion_ci->{$_} ? ( $_ => $order_portion_ci->{$_} ) : ()
- } @$unqualified_idset;
+ my @conds;
- # extra optimization - cut the order_by at the end of the identifying set
- # (just in case the user was stupid and overlooked the obvious)
- for my $i (0 .. $#ord_cols) {
- my $col = $ord_cols[$i];
- my $unqualified_colname = $order_portion_ci->{$col}{-colname};
- $ret_info->{$col} = { %{$order_portion_ci->{$col}}, -idx_in_order_subset => $i };
- delete $unqualified_idcols_from_order{$ret_info->{$col}{-colname}};
+ while (@$pairs) {
+ my ($lhs, $rhs) = splice @$pairs, 0, 2;
- # we didn't reach the end of the identifying portion yet
- return $ret_info unless keys %unqualified_idcols_from_order;
+ if (! length $lhs) {
+ push @conds, $self->_collapse_cond($rhs);
+ }
+ elsif ( $lhs =~ /^\-and$/i ) {
+ push @conds, $self->_collapse_cond($rhs, (ref $rhs eq 'ARRAY'));
+ }
+ elsif ( $lhs =~ /^\-or$/i ) {
+ push @conds, $self->_collapse_cond(
+ (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs
+ );
+ }
+ else {
+ if (ref $rhs eq 'HASH' and ! keys %$rhs) {
+ # FIXME - SQLA seems to be doing... nothing...?
+ }
+ # normalize top level -ident, for saner extract_fixed_condition_columns code
+ elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) {
+ push @conds, { $lhs => { '=', $rhs } };
+ }
+ elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) {
+ push @conds, { $lhs => $rhs->{-value} };
+ }
+ elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) {
+ if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) {
+ push @conds, { $lhs => $rhs };
+ }
+ else {
+ for my $p ($self->_collapse_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) {
+
+ # extra sanity check
+ if (keys %$p > 1) {
+ require Data::Dumper::Concise;
+ local $Data::Dumper::Deepcopy = 1;
+ $self->throw_exception(
+ "Internal error: unexpected collapse unroll:"
+ . Data::Dumper::Concise::Dumper { in => { $lhs => $rhs }, out => $p }
+ );
+ }
+
+ my ($l, $r) = %$p;
+
+ push @conds, (
+ ! length ref $r
+ or
+ # the unroller recursion may return a '=' prepended value already
+ ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}
+ or
+ is_plain_value($r)
+ )
+ ? { $l => $r }
+ : { $l => { '=' => $r } }
+ ;
+ }
+ }
+ }
+ elsif (ref $rhs eq 'ARRAY') {
+ # some of these conditionals encounter multi-values - roll them out using
+ # an unshift, which will cause extra looping in the while{} above
+ if (! @$rhs ) {
+ push @conds, { $lhs => [] };
+ }
+ elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) {
+ $self->throw_exception("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ")
+ if @$rhs == 1;
+
+ if( $rhs->[0] =~ /^\-and$/i ) {
+ unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs];
+ }
+ # if not an AND then it's an OR
+ elsif(@$rhs == 2) {
+ unshift @$pairs, $lhs => $rhs->[1];
+ }
+ else {
+ push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] };
+ }
+ }
+ elsif (@$rhs == 1) {
+ unshift @$pairs, $lhs => $rhs->[0];
+ }
+ else {
+ push @conds, { $lhs => $rhs };
+ }
+ }
+ # unroll func + { -value => ... }
+ elsif (
+ ref $rhs eq 'HASH'
+ and
+ ( my ($subop) = keys %$rhs ) == 1
+ and
+ length ref ((values %$rhs)[0])
+ and
+ my $vref = is_plain_value( (values %$rhs)[0] )
+ ) {
+ push @conds, { $lhs => { $subop => $$vref } }
+ }
+ else {
+ push @conds, { $lhs => $rhs };
+ }
+ }
}
- die 'How did we get here...';
+ return @conds;
}
-# returns an arrayref of column names which *definitely* have some
-# sort of non-nullable equality requested in the given condition
-# specification. This is used to figure out if a resultset is
-# constrained to a column which is part of a unique constraint,
-# which in turn allows us to better predict how ordering will behave
-# etc.
+# Analyzes a given condition and attempts to extract all columns
+# with a definitive fixed-condition criteria. Returns a hashref
+# of k/v pairs suitable to be passed to set_columns(), with a
+# MAJOR CAVEAT - multi-value (contradictory) equalities are still
+# represented as a reference to the UNRESOVABLE_CONDITION constant
+# The reason we do this is that some codepaths only care about the
+# codition being stable, as opposed to actually making sense
+#
+# The normal mode is used to figure out if a resultset is constrained
+# to a column which is part of a unique constraint, which in turn
+# allows us to better predict how ordering will behave etc.
+#
+# With the optional "consider_nulls" boolean argument, the function
+# is instead used to infer inambiguous values from conditions
+# (e.g. the inheritance of resultset conditions on new_result)
#
-# this is a rudimentary, incomplete, and error-prone extractor
-# however this is OK - it is conservative, and if we can not find
-# something that is in fact there - the stack will recover gracefully
-# Also - DQ and the mst it rode in on will save us all RSN!!!
sub _extract_fixed_condition_columns {
- my ($self, $where) = @_;
+ my ($self, $where, $consider_nulls) = @_;
+ my $where_hash = $self->_collapse_cond($_[1]);
- return unless ref $where eq 'HASH';
+ my $res = {};
+ my ($c, $v);
+ for $c (keys %$where_hash) {
+ my $vals;
- my @cols;
- for my $lhs (keys %$where) {
- if ($lhs =~ /^\-and$/i) {
- push @cols, ref $where->{$lhs} eq 'ARRAY'
- ? ( map { @{ $self->_extract_fixed_condition_columns($_) } } @{$where->{$lhs}} )
- : @{ $self->_extract_fixed_condition_columns($where->{$lhs}) }
- ;
+ if (!defined ($v = $where_hash->{$c}) ) {
+ $vals->{UNDEF} = $v if $consider_nulls
+ }
+ elsif (
+ ref $v eq 'HASH'
+ and
+ keys %$v == 1
+ ) {
+ if (exists $v->{-value}) {
+ if (defined $v->{-value}) {
+ $vals->{"VAL_$v->{-value}"} = $v->{-value}
+ }
+ elsif( $consider_nulls ) {
+ $vals->{UNDEF} = $v->{-value};
+ }
+ }
+ # do not need to check for plain values - _collapse_cond did it for us
+ elsif(
+ length ref $v->{'='}
+ and
+ (
+ ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} )
+ or
+ is_literal_value($v->{'='})
+ )
+ ) {
+ $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='};
+ }
+ }
+ elsif (
+ ! length ref $v
+ or
+ is_plain_value ($v)
+ ) {
+ $vals->{"VAL_$v"} = $v;
+ }
+ elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') {
+ for ( @{$v}[1..$#$v] ) {
+ my $subval = $self->_extract_fixed_condition_columns({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion
+ next unless exists $subval->{$c}; # didn't find anything
+ $vals->{
+ ! defined $subval->{$c} ? 'UNDEF'
+ : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}"
+ : ( 'SER_' . serialize $subval->{$c} )
+ } = $subval->{$c};
+ }
}
- elsif ($lhs !~ /^\-/) {
- my $val = $where->{$lhs};
- push @cols, $lhs if (defined $val and (
- ! ref $val
- or
- (ref $val eq 'HASH' and keys %$val == 1 and defined $val->{'='})
- ));
+ if (keys %$vals == 1) {
+ ($res->{$c}) = (values %$vals)
+ unless !$consider_nulls and exists $vals->{UNDEF};
+ }
+ elsif (keys %$vals > 1) {
+ $res->{$c} = UNRESOLVABLE_CONDITION;
}
}
- return \@cols;
+
+ $res;
}
1;
package DBIx::Class::Storage::Statistics;
+
use strict;
use warnings;
-use base qw/DBIx::Class/;
-use IO::File;
+use DBIx::Class::_Util qw(sigwarn_silencer qsub);
+use IO::Handle ();
+use Moo;
+extends 'DBIx::Class';
use namespace::clean;
-__PACKAGE__->mk_group_accessors(simple => qw/callback _debugfh silence/);
-
=head1 NAME
DBIx::Class::Storage::Statistics - SQL Statistics
=head1 METHODS
-=cut
-
=head2 new
Returns a new L<DBIx::Class::Storage::Statistics> object.
-=cut
-sub new {
- my $self = {};
- bless $self, (ref($_[0]) || $_[0]);
-
- return $self;
-}
-
=head2 debugfh
Sets or retrieves the filehandle used for trace/debug output. This should
-be an IO::Handle compatible object (only the C<print> method is used). Initially
-should be set to STDERR - although see information on the
-L<DBIC_TRACE> environment variable.
+be an L<IO::Handle> compatible object (only the
+L<< print|IO::Handle/METHODS >> method is used). By
+default it is initially set to STDERR - although see discussion of the
+L<DBIC_TRACE|DBIx::Class::Storage/DBIC_TRACE> environment variable.
-As getter it will lazily open a filehandle for you if one is not already set.
+Invoked as a getter it will lazily open a filehandle and set it to
+L<< autoflush|perlvar/HANDLE->autoflush( EXPR ) >> (if one is not
+already set).
=cut
-sub debugfh {
- my $self = shift;
+has debugfh => (
+ is => 'rw',
+ lazy => 1,
+ trigger => qsub '$_[0]->_defaulted_to_stderr(undef); $_[0]->_clear_debugfh unless $_[1];',
+ clearer => '_clear_debugfh',
+ builder => '_build_debugfh',
+);
+
+sub _build_debugfh {
+ my $fh;
+
+ my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
- if (@_) {
- $self->_debugfh($_[0]);
- } elsif (!defined($self->_debugfh())) {
- my $fh;
- my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
- || $ENV{DBIC_TRACE};
- if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
- $fh = IO::File->new($1, 'a')
- or die("Cannot open trace file $1");
- } else {
- $fh = IO::File->new('>&STDERR')
- or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
- }
-
- $fh->autoflush();
- $self->_debugfh($fh);
+ if (defined($debug_env) and ($debug_env =~ /=(.+)$/)) {
+ open ($fh, '>>', $1)
+ or die("Cannot open trace file $1: $!\n");
}
+ else {
+ open ($fh, '>&STDERR')
+ or die("Duplication of STDERR for debug output failed (perhaps your STDERR is closed?): $!\n");
+ $_[0]->_defaulted_to_stderr(1);
+ }
+
+ $fh->autoflush(1);
- $self->_debugfh;
+ $fh;
}
+has [qw(_defaulted_to_stderr silence callback)] => (
+ is => 'rw',
+);
+
=head2 print
Prints the specified string to our debugging filehandle. Provided to save our
return if $self->silence;
- $self->debugfh->print($msg);
+ my $fh = $self->debugfh;
+
+ # not using 'no warnings' here because all of this can change at runtime
+ local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/)
+ if $self->_defaulted_to_stderr;
+
+ $fh->print($msg);
}
=head2 silence
Called when a query finishes executing. Has the same arguments as query_start.
=cut
+
sub query_end {
my ($self, $string) = @_;
}
-1;
-
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
+
+1;
use strict;
use warnings;
-use Try::Tiny;
-use Scalar::Util qw/weaken blessed refaddr/;
+use Scalar::Util qw(weaken blessed refaddr);
use DBIx::Class;
-use DBIx::Class::_Util 'is_exception';
+use DBIx::Class::_Util qw(is_exception detected_reinvoked_destructor);
use DBIx::Class::Carp;
use namespace::clean;
# FIXME FRAGILE - any eval that fails but *does not* rethrow between here
# and the unwind will trample over $@ and invalidate the entire mechanism
# There got to be a saner way of doing this...
- if (is_exception $@) {
+ #
+ # Deliberately *NOT* using is_exception - if someone left a misbehaving
+ # antipattern value in $@, it's not our business to whine about it
+ if( defined $@ and length $@ ) {
weaken(
- $guard->{existing_exception_ref} = (ref($@) eq '') ? \$@ : $@
+ $guard->{existing_exception_ref} = (length ref $@) ? $@ : \$@
);
}
$self->{storage}->throw_exception("Refusing to execute multiple commits on scope guard $self")
if $self->{inactivated};
- $self->{storage}->txn_commit;
+ # FIXME - this assumption may be premature: a commit may fail and a rollback
+ # *still* be necessary. Currently I am not aware of such scenarious, but I
+ # also know the deferred constraint handling is *severely* undertested.
+ # Making the change of "fire txn and never come back to this" in order to
+ # address RT#107159, but this *MUST* be reevaluated later.
$self->{inactivated} = 1;
+ $self->{storage}->txn_commit;
}
sub DESTROY {
- my $self = shift;
+ return if &detected_reinvoked_destructor;
- return if $self->{inactivated};
+ return if $_[0]->{inactivated};
- # if our dbh is not ours anymore, the $dbh weakref will go undef
- $self->{storage}->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- return unless $self->{dbh};
- my $exception = $@ if (
+ # grab it before we've done volatile stuff below
+ my $current_exception = (
is_exception $@
and
(
- ! defined $self->{existing_exception_ref}
+ ! defined $_[0]->{existing_exception_ref}
or
- refaddr( ref($@) eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref})
+ refaddr( (length ref $@) ? $@ : \$@ ) != refaddr($_[0]->{existing_exception_ref})
)
- );
-
- {
- local $@;
-
- carp 'A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back.'
- unless defined $exception;
-
- my $rollback_exception;
- # do minimal connectivity check due to weird shit like
- # https://rt.cpan.org/Public/Bug/Display.html?id=62370
- try { $self->{storage}->_seems_connected && $self->{storage}->txn_rollback }
- catch { $rollback_exception = shift };
-
- if ( $rollback_exception and (
- ! defined blessed $rollback_exception
- or
- ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
- ) ) {
- # append our text - THIS IS A TEMPORARY FIXUP!
- # a real stackable exception object is in the works
- if (ref $exception eq 'DBIx::Class::Exception') {
- $exception->{msg} = "Transaction aborted: $exception->{msg} "
- ."Rollback failed: ${rollback_exception}";
- }
- elsif ($exception) {
- $exception = "Transaction aborted: ${exception} "
- ."Rollback failed: ${rollback_exception}";
- }
- else {
- carp (join ' ',
- "********************* ROLLBACK FAILED!!! ********************",
- "\nA rollback operation failed after the guard went out of scope.",
- 'This is potentially a disastrous situation, check your data for',
- "consistency: $rollback_exception"
- );
- }
- }
+ )
+ ? $@
+ : undef
+ ;
+
+
+ # if our dbh is not ours anymore, the $dbh weakref will go undef
+ $_[0]->{storage}->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+ return unless defined $_[0]->{dbh};
+
+
+ carp 'A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back'
+ unless defined $current_exception;
+
+
+ if (
+ my $rollback_exception = $_[0]->{storage}->__delicate_rollback(
+ defined $current_exception
+ ? \$current_exception
+ : ()
+ )
+ and
+ ! defined $current_exception
+ ) {
+ carp (join ' ',
+ "********************* ROLLBACK FAILED!!! ********************",
+ "\nA rollback operation failed after the guard went out of scope.",
+ 'This is potentially a disastrous situation, check your data for',
+ "consistency: $rollback_exception"
+ );
}
- $@ = $exception;
+ $@ = $current_exception
+ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
1;
L<DBIx::Class::Schema/txn_scope_guard>.
-=head1 AUTHOR
+L<Scope::Guard> by chocolateboy (inspiration for this module)
-Ash Berlin, 2008.
+=head1 FURTHER QUESTIONS?
-Inspired by L<Scope::Guard> by chocolateboy.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-This module is free software. It may be used, redistributed and/or modified
-under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
return ($_[0]->utf8_columns || {})->{$_[1]};
}
-=head1 AUTHORS
+=head1 FURTHER QUESTIONS?
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
use warnings;
use strict;
-use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0);
+use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0);
BEGIN {
package # hide from pause
# but of course
BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0,
+ BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0,
+
HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
- # ::Runmode would only be loaded by DBICTest, which in turn implies t/
- DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0,
+ UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0,
- # During 5.13 dev cycle HELEMs started to leak on copy
- PEEPEENESS =>
- # request for all tests would force "non-leaky" illusion and vice-versa
- defined $ENV{DBICTEST_ALL_LEAKS} ? !$ENV{DBICTEST_ALL_LEAKS}
- # otherwise confess that this perl is busted ONLY on smokers
- : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ? 1
- # otherwise we are good
- : 0
- ,
+ DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0,
- ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
+ # During 5.13 dev cycle HELEMs started to leak on copy
+ # add an escape for these perls ON SMOKERS - a user will still get death
+ PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ( "$]" >= 5.013005 and "$]" <= 5.013006) ),
+
+ ( map
+ #
+ # the "DBIC_" prefix below is crucial - this is what makes CI pick up
+ # all envvars without further adjusting its scripts
+ # DO NOT CHANGE to the more logical { $_ => !!( $ENV{"DBIC_$_"} ) }
+ #
+ { substr($_, 5) => !!( $ENV{$_} ) }
+ qw(
+ DBIC_SHUFFLE_UNORDERED_RESULTSETS
+ DBIC_ASSERT_NO_INTERNAL_WANTARRAY
+ DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
+ DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
+ )
+ ),
IV_SIZE => $Config{ivsize},
OS_NAME => $^O,
};
- if ($] < 5.009_005) {
+ if ( "$]" < 5.009_005) {
require MRO::Compat;
constant->import( OLD_MRO => 1 );
}
# Carp::Skip to the rescue soon
use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
+use B ();
use Carp 'croak';
-use Scalar::Util qw(weaken blessed reftype);
+use Storable 'nfreeze';
+use Scalar::Util qw(weaken blessed reftype refaddr);
+use List::Util qw(first);
+use Sub::Quote qw(qsub quote_sub);
+
+# Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
+BEGIN { *deep_clone = \&Storable::dclone }
use base 'Exporter';
-our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount hrefaddr is_exception);
+our @EXPORT_OK = qw(
+ sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
+ fail_on_internal_wantarray fail_on_internal_call
+ refdesc refcount hrefaddr
+ scope_guard detected_reinvoked_destructor
+ is_exception dbic_internal_try
+ quote_sub qsub perlstring serialize deep_clone
+ UNRESOLVABLE_CONDITION
+);
+
+use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
sub sigwarn_silencer ($) {
my $pattern = shift;
return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
}
-sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr }
+sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
+
+sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 }
+
+sub refdesc ($) {
+ croak "Expecting a reference" if ! length ref $_[0];
+
+ # be careful not to trigger stringification,
+ # reuse @_ as a scratch-pad
+ sprintf '%s%s(0x%x)',
+ ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
+ reftype $_[0],
+ refaddr($_[0]),
+ ;
+}
sub refcount ($) {
croak "Expecting a reference" if ! length ref $_[0];
- require B;
# No tempvars - must operate on $_[0], otherwise the pad
# will count as an extra ref
B::svref_2object($_[0])->REFCNT;
}
+sub serialize ($) {
+ local $Storable::canonical = 1;
+ nfreeze($_[0]);
+}
+
+sub scope_guard (&) {
+ croak 'Calling scope_guard() in void context makes no sense'
+ if ! defined wantarray;
+
+ # no direct blessing of coderefs - DESTROY is buggy on those
+ bless [ $_[0] ], 'DBIx::Class::_Util::ScopeGuard';
+}
+{
+ package #
+ DBIx::Class::_Util::ScopeGuard;
+
+ sub DESTROY {
+ &DBIx::Class::_Util::detected_reinvoked_destructor;
+
+ local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
+
+ eval {
+ $_[0]->[0]->();
+ 1;
+ }
+ or
+ Carp::cluck(
+ "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@"
+ );
+ }
+}
+
+
sub is_exception ($) {
my $e = $_[0];
+ # FIXME
# this is not strictly correct - an eval setting $@ to undef
# is *not* the same as an eval setting $@ to ''
# but for the sake of simplicity assume the following for
{
local $@;
eval {
- $not_blank = ($e ne '') ? 1 : 0;
+ # The ne() here is deliberate - a plain length($e), or worse "$e" ne
+ # will entirely obviate the need for the encolsing eval{}, as the
+ # condition we guard against is a missing fallback overload
+ $not_blank = ( $e ne '' );
1;
} or $suberror = $@;
}
if (defined $suberror) {
if (length (my $class = blessed($e) )) {
carp_unique( sprintf(
- 'External exception object %s=%s(%s) implements partial (broken) '
- . 'overloading preventing it from being used in simple ($x eq $y) '
+ 'External exception class %s implements partial (broken) overloading '
+ . 'preventing its instances from being used in simple ($x eq $y) '
. 'comparisons. Given Perl\'s "globally cooperative" exception '
. 'handling this type of brokenness is extremely dangerous on '
. 'exception objects, as it may (and often does) result in silent '
. 'is saner application-wide. What follows is the actual error text '
. "as generated by Perl itself:\n\n%s\n ",
$class,
- reftype $e,
- hrefaddr $e,
$class,
'http://v.gd/DBIC_overload_tempfix/',
$suberror,
));
# workaround, keeps spice flowing
- $not_blank = ("$e" ne '') ? 1 : 0;
+ $not_blank = !!( length $e );
}
else {
# not blessed yet failed the 'ne'... this makes 0 sense...
die $suberror
}
}
+ elsif (
+ # a ref evaluating to '' is definitively a "null object"
+ ( not $not_blank )
+ and
+ length( my $class = ref $e )
+ ) {
+ carp_unique( sprintf(
+ "Objects of external exception class '%s' stringify to '' (the "
+ . 'empty string), implementing the so called null-object-pattern. '
+ . 'Given Perl\'s "globally cooperative" exception handling using this '
+ . 'class of exceptions is extremely dangerous, as it may (and often '
+ . 'does) result in silent discarding of errors. DBIx::Class tries to '
+ . 'work around this as much as possible, but other parts of your '
+ . 'software stack may not be even aware of the problem. Please submit '
+ . 'a bugreport against the distribution containing %s',
+
+ ($class) x 2,
+ ));
+
+ $not_blank = 1;
+ }
return $not_blank;
}
+{
+ my $callstack_state;
+
+ # Recreate the logic of try(), while reusing the catch()/finally() as-is
+ #
+ # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
+ # yes, shows up ON TOP of profiles) but this is a batle for another maint
+ sub dbic_internal_try (&;@) {
+
+ my $try_cref = shift;
+ my $catch_cref = undef; # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
+
+ for my $arg (@_) {
+
+ if( ref($arg) eq 'Try::Tiny::Catch' ) {
+
+ croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
+ if $catch_cref;
+
+ $catch_cref = $$arg;
+ }
+ elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
+ croak 'dbic_internal_try() does not support finally{}';
+ }
+ else {
+ croak(
+ 'dbic_internal_try() encountered an unexpected argument '
+ . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
+ . 'a missing semi-colon before or ' # trailing space important
+ );
+ }
+ }
+
+ my $wantarray = wantarray;
+ my $preexisting_exception = $@;
+
+ my @ret;
+ my $all_good = eval {
+ $@ = $preexisting_exception;
+
+ local $callstack_state->{in_internal_try} = 1
+ unless $callstack_state->{in_internal_try};
+
+ # always unset - someone may have snuck it in
+ local $SIG{__DIE__}
+ if $SIG{__DIE__};
+
+
+ if( $wantarray ) {
+ @ret = $try_cref->();
+ }
+ elsif( defined $wantarray ) {
+ $ret[0] = $try_cref->();
+ }
+ else {
+ $try_cref->();
+ }
+
+ 1;
+ };
+
+ my $exception = $@;
+ $@ = $preexisting_exception;
+
+ if ( $all_good ) {
+ return $wantarray ? @ret : $ret[0]
+ }
+ elsif ( $catch_cref ) {
+ for ( $exception ) {
+ return $catch_cref->($exception);
+ }
+ }
+
+ return;
+ }
+
+ sub in_internal_try { !! $callstack_state->{in_internal_try} }
+}
+
+{
+ my $destruction_registry = {};
+
+ sub CLONE {
+ $destruction_registry = { map
+ { defined $_ ? ( refaddr($_) => $_ ) : () }
+ values %$destruction_registry
+ };
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
+ }
+
+ # This is almost invariably invoked from within DESTROY
+ # throwing exceptions won't work
+ sub detected_reinvoked_destructor {
+
+ # quick "garbage collection" pass - prevents the registry
+ # from slowly growing with a bunch of undef-valued keys
+ defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
+ for keys %$destruction_registry;
+
+ if (! length ref $_[0]) {
+ printf STDERR '%s() expects a blessed reference %s',
+ (caller(0))[3],
+ Carp::longmess,
+ ;
+ return undef; # don't know wtf to do
+ }
+ elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
+ weaken( $destruction_registry->{$addr} = $_[0] );
+ return 0;
+ }
+ else {
+ carp_unique ( sprintf (
+ 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
+ . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
+ . 'application, affecting *ALL* classes without active protection against '
+ . 'this. Diagnose and fix the root cause ASAP!!!%s',
+ refdesc $_[0],
+ ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } )
+ ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)"
+ : ''
+ )
+ ));
+
+ return 1;
+ }
+ }
+}
+
+my $module_name_rx = qr/ \A [A-Z_a-z] [0-9A-Z_a-z]* (?: :: [0-9A-Z_a-z]+ )* \z /x;
+my $ver_rx = qr/ \A [0-9]+ (?: \. [0-9]+ )* (?: \_ [0-9]+ )* \z /x;
+
sub modver_gt_or_eq ($$) {
my ($mod, $ver) = @_;
croak "Nonsensical module name supplied"
- if ! defined $mod or ! length $mod;
+ if ! defined $mod or $mod !~ $module_name_rx;
croak "Nonsensical minimum version supplied"
- if ! defined $ver or $ver =~ /[^0-9\.\_]/;
+ if ! defined $ver or $ver !~ $ver_rx;
+
+ no strict 'refs';
+ my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
+ ? {}
+ : croak "$mod does not seem to provide a version (perhaps it never loaded)"
+ );
+
+ ! defined $ver_cache->{$ver}
+ and
+ $ver_cache->{$ver} = do {
+
+ local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
+ if SPURIOUS_VERSION_CHECK_WARNINGS;
+
+ local $@;
+ local $SIG{__DIE__};
+ eval { $mod->VERSION($ver) } ? 1 : 0;
+ };
+
+ $ver_cache->{$ver};
+}
- local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
- if SPURIOUS_VERSION_CHECK_WARNINGS;
+sub modver_gt_or_eq_and_lt ($$$) {
+ my ($mod, $v_ge, $v_lt) = @_;
- local $@;
- eval { $mod->VERSION($ver) } ? 1 : 0;
+ croak "Nonsensical maximum version supplied"
+ if ! defined $v_lt or $v_lt !~ $ver_rx;
+
+ return (
+ modver_gt_or_eq($mod, $v_ge)
+ and
+ ! modver_gt_or_eq($mod, $v_lt)
+ ) ? 1 : 0;
}
{
my $list_ctx_ok_stack_marker;
- sub fail_on_internal_wantarray {
+ sub fail_on_internal_wantarray () {
return if $list_ctx_ok_stack_marker;
if (! defined wantarray) {
}
my $cf = 1;
- while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
+ while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
# these are public API parts that alter behavior on wantarray
search | search_related | slice | search_literal
$cf++;
}
+ my ($fr, $want, $argdesc);
+ {
+ package DB;
+ $fr = [ CORE::caller($cf) ];
+ $want = ( CORE::caller($cf-1) )[5];
+ $argdesc = ref $DB::args[0]
+ ? DBIx::Class::_Util::refdesc($DB::args[0])
+ : 'non '
+ ;
+ };
+
if (
- (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
+ $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
) {
- my $obj = shift;
-
DBIx::Class::Exception->throw( sprintf (
- "Improper use of %s(%s) instance in list context at %s line %d\n\n\tStacktrace starts",
- ref($obj), hrefaddr($obj), (caller($cf))[1,2]
+ "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts",
+ $argdesc, @{$fr}[1,2]
), 'with_stacktrace');
}
}
}
+sub fail_on_internal_call {
+ my ($fr, $argdesc);
+ {
+ package DB;
+ $fr = [ CORE::caller(1) ];
+ $argdesc = ref $DB::args[0]
+ ? DBIx::Class::_Util::refdesc($DB::args[0])
+ : undef
+ ;
+ };
+
+ if (
+ $argdesc
+ and
+ $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+ and
+ $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there
+ ) {
+ DBIx::Class::Exception->throw( sprintf (
+ "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts",
+ $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
+ require B::Deparse;
+ no strict 'refs';
+ B::Deparse->new->coderef2text(\&{$fr->[3]})
+ }),
+ ), 'with_stacktrace');
+ }
+}
+
1;
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Exception;
+use Class::C3::Componentised;
use Scalar::Util 'blessed';
use Try::Tiny;
use namespace::clean;
DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema);
if (!ref $dbicschema) {
- eval "require $dbicschema"
- or DBIx::Class::Exception->throw("Can't load $dbicschema: $@");
+ dbic_internal_try {
+ Class::C3::Componentised->ensure_class_loaded($dbicschema)
+ } catch {
+ DBIx::Class::Exception->throw("Can't load $dbicschema: $_");
+ }
}
if (
# global add_fk_index set in parser_args
my $add_fk_index = (exists $args->{add_fk_index} && ! $args->{add_fk_index}) ? 0 : 1;
- foreach my $rel (sort @rels)
- {
+ REL:
+ foreach my $rel (sort @rels) {
my $rel_info = $source->relationship_info($rel);
# Ignore any rel cond that isn't a straight hash
next unless ref $rel_info->{cond} eq 'HASH';
- my $relsource = try { $source->related_source($rel) };
+ my $relsource = dbic_internal_try { $source->related_source($rel) };
unless ($relsource) {
- carp "Ignoring relationship '$rel' - related resultsource '$rel_info->{class}' is not registered with this schema\n";
+ carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '$rel_info->{class}' is not registered with this schema\n";
next;
};
# support quoting properly to be signaled about this
$rel_table = $$rel_table if ref $rel_table eq 'SCALAR';
- my $reverse_rels = $source->reverse_relationship_info($rel);
- my ($otherrelname, $otherrelationship) = each %{$reverse_rels};
-
# Force the order of @cond to match the order of ->add_columns
my $idx;
my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns;
- my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
+
+ for ( keys %{$rel_info->{cond}} ) {
+ unless (exists $other_columns_idx{$_}) {
+ carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '@{[ $relsource->source_name ]}' does not contain one of the specified columns: '$_'\n";
+ next REL;
+ }
+ }
+
+ my @cond = sort { $other_columns_idx{$a} <=> $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
# Get the key information, mapping off the foreign/self markers
my @refkeys = map {/^\w+\.(\w+)$/} @cond;
$fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary);
}
+ my ($otherrelname, $otherrelationship) = %{ $source->reverse_relationship_info($rel) };
+
my $cascade;
for my $c (qw/delete update/) {
if (exists $rel_info->{attrs}{"on_$c"}) {
$tables{$table_name}{foreign_table_deps}{$rel_table}++;
}
+ # trim schema before generating constraint/index names
+ (my $table_abbrev = $table_name) =~ s/ ^ [^\.]+ \. //x;
+
$table->add_constraint(
type => 'foreign_key',
- name => join('_', $table_name, 'fk', @keys),
+ name => join('_', $table_abbrev, 'fk', @keys),
fields => \@keys,
reference_fields => \@refkeys,
reference_table => $rel_table,
next if join("\x00", @keys) eq join("\x00", @primary);
if ($add_fk_index_rel) {
+ (my $idx_name = $table_name) =~ s/ ^ [^\.]+ \. //x;
my $index = $table->add_index(
- name => join('_', $table_name, 'idx', @keys),
+ name => join('_', $table_abbrev, 'idx', @keys),
fields => \@keys,
type => 'NORMAL',
);
L<SQL::Translator>, L<DBIx::Class::Schema>
-=head1 AUTHORS
-
-See L<DBIx::Class/CONTRIBUTORS>.
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
Creates a DBIx::Class::Schema for use with DBIx::Class
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
=cut
use strict;
require File::Spec;
require File::Find;
-my $xt_dirs;
+my $xt_dist_dirs;
File::Find::find(sub {
- return if $xt_dirs->{$File::Find::dir};
- $xt_dirs->{$File::Find::dir} = 1 if (
+ return if $xt_dist_dirs->{$File::Find::dir};
+ $xt_dist_dirs->{$File::Find::dir} = 1 if (
$_ =~ /\.t$/ and -f $_
);
-}, 'xt');
+}, 'xt/dist');
-my @xt_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs;
-
-# this will add the xt tests to the `make test` target among other things
-Meta->tests(join (' ', map { $_ || () } @xt_tests, Meta->tests ) );
+my @xt_dist_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dist_dirs;
# inject an explicit xt test run, mainly to check the contents of
# lib and the generated POD's *before* anything is copied around
#
-# at the end rerun the whitespace test in the distdir, to make sure everything
-# is pristine
+# at the end rerun the whitespace and footer tests in the distdir
+# to make sure everything is pristine
postamble <<"EOP";
dbic_clonedir_copy_generated_pod : test_xt
),
# test list
join( ' ',
- map { $mm_proto->quote_literal($_) } @xt_tests
+ map { $mm_proto->quote_literal($_) } @xt_dist_tests
),
)
]}
-create_distdir : dbic_distdir_retest_whitespace
+create_distdir : dbic_distdir_retest_ws_and_footers
-dbic_distdir_retest_whitespace :
+dbic_distdir_retest_ws_and_footers :
\t@{[
$mm_proto->cd (
'$(DISTVNAME)',
'$(ABSPERLRUN)',
map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;)
),
- 'xt/whitespace.t'
+ 'xt/dist/postdistdir/*.t',
)
)
]}
EOW
require DBIx::Class::Optional::Dependencies;
- my %reqs_for_group = %{DBIx::Class::Optional::Dependencies->req_group_list};
# exclude the rdbms_* groups which are for DBIC users
- $opt_testdeps = {
- map { %{$reqs_for_group{$_}} } grep { !/^rdbms_|^dist_/ } keys %reqs_for_group
- };
+ # and the moose-related stuff iff we are under 5.8.3
+ $opt_testdeps = DBIx::Class::Optional::Dependencies->req_list_for([
+ grep {
+ !/^rdbms_|^dist_/
+ and
+ ( "$]" > 5.008002 or !/^ (?: test_ )? (?: admin | admin_script | replicated ) $/x )
+ } keys %{DBIx::Class::Optional::Dependencies->req_group_list}
+ ]);
+
+ # this one is "special" - we need it both in optdeps and as a hard dep
+ delete $opt_testdeps->{'DBD::SQLite'};
print "Including all optional deps\n";
$reqs->{test_requires} = {
if (keys %removed_build_requires) {
print "Regenerating META with author requires excluded\n";
+ # 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/ };
Meta->write;
}
+++ /dev/null
-print "Appending to the no_index META list\n";
-
-# Deprecated/internal modules need no exposure when building the meta
-no_index directory => $_ for (qw|
- lib/DBIx/Class/Admin
- lib/DBIx/Class/PK/Auto
- lib/DBIx/Class/CDBICompat
- maint
-|);
-no_index package => $_ for (qw/
- DBIx::Class::Storage::DBIHacks
- DBIx::Class::Storage::BlockRunner
- DBIx::Class::Carp
- DBIx::Class::_Util
- DBIx::Class::ResultSet::Pager
-/);
-
-# keep the Makefile.PL eval happy
-1;
--- /dev/null
+# principal author list is kinda mandated by spec, luckily is rather static
+author 'mst: Matt S Trout <mst@shadowcat.co.uk> (project founder - original idea, architecture and implementation)';
+author 'castaway: Jess Robinson <castaway@desert-island.me.uk> (lions share of the reference documentation and manuals)';
+author 'ribasushi: Peter Rabbitson <ribasushi@cpan.org> (present day maintenance and controlled evolution)';
+
+# pause sanity
+Meta->{values}{x_authority} = 'cpan:RIBASUSHI';
+
+# !!!experimental!!!
+#
+# <ribasushi> am wondering if an x_parallel_test => 1 and x_parallel_depchain_test => 1 would be of use in meta
+# <ribasushi> to signify "project keeps tabs on itself and depchain to be in good health wrt running tests in parallel"
+# <ribasushi> and having cpan(m) tack a -j6 automatically for that
+# <ribasushi> it basically allows you to first consider any "high level intermediate dist" advertising "all my stuff works" so that larger swaths of CPAN get installed first under parallel
+# <ribasushi> note - this is not "spur of the moment" - I first started testing my depchain in parallel 3 years ago
+# <ribasushi> and have had it stable ( religiously tested on travis on any commit ) for about 2 years now
+#
+Meta->{values}{x_parallel_test_certified} = 1;
+Meta->{values}{x_dependencies_parallel_test_certified} = 1;
+
+# populate x_contributors
+# a direct dump of the sort is ok - xt/authors.t guarantees source sanity
+Meta->{values}{x_contributors} = [ do {
+ # according to #p5p this is how one safely reads random unicode
+ # this set of boilerplate is insane... wasn't perl unicode-king...?
+ no warnings 'once';
+ require Encode;
+ require PerlIO::encoding;
+ local $PerlIO::encoding::fallback = Encode::FB_CROAK();
+
+ open (my $fh, '<:encoding(UTF-8)', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n";
+ map { chomp; ( (! $_ or $_ =~ /^\s*\#/) ? () : $_ ) } <$fh>;
+
+}];
+
+# legalese
+license 'perl';
+resources 'license' => 'http://dev.perl.org/licenses/';
+
+# misc resources
+abstract_from 'lib/DBIx/Class.pm';
+resources 'homepage' => 'http://www.dbix-class.org/';
+resources 'IRC' => 'irc://irc.perl.org/#dbix-class';
+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';
+
+# nothing determined at runtime, except for possibly SQLT dep
+# (see the check around DBICTEST_SQLT_DEPLOY in Makefile.PL)
+dynamic_config 0;
+
+# Deprecated/internal modules need no exposure when building the meta
+no_index directory => $_ for (qw|
+ lib/DBIx/Class/Admin
+ lib/DBIx/Class/PK/Auto
+ lib/DBIx/Class/CDBICompat
+ maint
+|);
+no_index package => $_ for (qw/
+ DBIx::Class::Storage::DBIHacks
+ DBIx::Class::Storage::BlockRunner
+ DBIx::Class::Carp
+ DBIx::Class::_Util
+ DBIx::Class::ResultSet::Pager
+/);
+
+# keep the Makefile.PL eval happy
+1;
-my $dbic_ver_re = qr/ (\d) \. (\d{2}) (\d{3}) (?: _ (\d{2}) )? /x; # not anchored!!!
+my $dbic_ver_re = qr/ 0 \. (\d{2}) (\d{2}) (\d{2}) (?: _ (\d{2}) )? /x; # not anchored!!!
my $version_string = Meta->version;
my $version_value = eval $version_string;
my ($v_maj, $v_min, $v_point, $v_dev) = $version_string =~ /^$dbic_ver_re$/
or die sprintf (
- "Invalid version %s (as specified in %s)\nCurrently valid version formats are M.VVPPP or M.VVPPP_DD\n",
+ "Invalid version %s (as specified in %s)\nCurrently valid version formats are 0.MMVVPP or 0.MMVVPP_DD\n",
$version_string,
Meta->{values}{version_from} || Meta->{values}{all_from} || 'Makefile.PL',
)
;
-if ($v_maj != 0 or $v_min > 8) {
+if ($v_maj > 8) {
die "Illegal version $version_string - we are still in the 0.08 cycle\n"
}
-if ($v_point >= 300) {
- die "Illegal version $version_string - we are still in the 0.082xx cycle\n"
-}
-
-Meta->makemaker_args->{DISTVNAME} = Meta->name . "-$version_string-TRIAL" if (
- # all odd releases *after* 0.08200 generate a -TRIAL, no exceptions
- ( $v_point > 200 and int($v_point / 100) % 2 )
-);
+#Meta->makemaker_args->{DISTVNAME} = Meta->name . "-$version_string-TRIAL" if (
+# ( $v_point > 89 )
+#);
my $tags = { map { chomp $_; $_ => 1} `git tag` };
my $shipped_versions;
my $shipped_dev_versions;
+ my $legacy_re = qr/^ v 0 \. (\d{2}) (\d{2}) (\d) (?: _ (\d{2}) )? $/x;
+
for (keys %$tags) {
- if ($_ =~ /^v$dbic_ver_re$/) {
+ if ($_ =~ /^v$dbic_ver_re$/ or $_ =~ $legacy_re ) {
if (defined $4) {
- $shipped_dev_versions->{"$1.$2$3$4"} = 1;
+ $shipped_dev_versions->{"0.$1$2$3$4"} = 1;
}
else {
- $shipped_versions->{"$1.$2$3"} = 1;
+ $shipped_versions->{"0.$1$2$3"} = 1;
}
delete $tags->{$_};
}
package MY;
sub distdir {
(my $snippet = shift->SUPER::distdir(@_)) =~ s/^create_distdir :/create_distdir_copy_manifested :/;
+ no warnings 'qw';
return <<"EOM";
$snippet
check_create_distdir_prereqs :
\t\$(NOECHO) @{[
- $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->die_unless_req_ok_for(q(dist_dir))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/])
+ $mm_proto->oneliner("1", [qw( -Ilib -MDBIx::Class::Optional::Dependencies=-die_without,dist_dir )])
]}
EOM
sub postamble {
my $snippet = shift->SUPER::postamble(@_);
+ no warnings 'qw';
return <<"EOM";
$snippet
check_upload_dist_prereqs :
\t\$(NOECHO) @{[
- $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->die_unless_req_ok_for(q(dist_upload))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/])
+ $mm_proto->oneliner("1", [qw( -Ilib -MDBIx::Class::Optional::Dependencies=-die_without,dist_upload )])
]}
EOM
+++ /dev/null
-# When a long-standing branch is updated a README may still linger around
-unlink 'README' if -f 'README';
-
-# Makefile syntax allows adding extra dep-specs for already-existing targets,
-# and simply appends them on *LAST*-come *FIRST*-serve basis.
-# This allows us to inject extra depenencies for standard EUMM targets
-
-require File::Spec;
-my $dir = File::Spec->catdir(qw(maint .Generated_Pod));
-my $fn = File::Spec->catfile($dir, 'README');
-
-postamble <<"EOP";
-
-clonedir_generate_files : dbic_clonedir_gen_readme
-
-dbic_clonedir_gen_readme :
-\t@{[ $mm_proto->oneliner('mkpath', ['-MExtUtils::Command']) ]} $dir
-\tpod2text lib/DBIx/Class.pm > $fn
-
-EOP
-
-# keep the Makefile.PL eval happy
-1;
my $great_success;
{
local @ARGV = ('--documentation-as-pod', $pod_fn);
+ local $0 = 'dbicadmin';
local *CORE::GLOBAL::exit = sub { $great_success++; die; };
do 'script/dbicadmin';
}
}
+# generate the DBIx/Class.pod only during distdir
+{
+ my $dist_pod_fn = File::Spec->catfile($pod_dir, qw(lib DBIx Class.pod));
+
+ postamble <<"EOP";
+
+clonedir_generate_files : dbic_distdir_gen_dbic_pod
+
+dbic_distdir_gen_dbic_pod :
+
+\tperldoc -u lib/DBIx/Class.pm > $dist_pod_fn
+\t@{[ $mm_proto->oneliner(
+ "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\n\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me",
+ [qw( -0777 -p -i )]
+) ]} $dist_pod_fn
+
+create_distdir : dbic_distdir_defang_authors
+
+# Remove the maintainer-only warning (be nice ;)
+dbic_distdir_defang_authors :
+\t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i )] ) ]} \$(DISTVNAME)/AUTHORS
+
+EOP
+}
+
+
# on some OSes generated files may have an incorrect \n - fix it
# so that the xt tests pass on a fresh checkout (also shipping a
# dist with CRLFs is beyond obnoxious)
--- /dev/null
+# When a long-standing branch is updated a README may still linger around
+unlink 'README' if -f 'README';
+
+# Makefile syntax allows adding extra dep-specs for already-existing targets,
+# and simply appends them on *LAST*-come *FIRST*-serve basis.
+# This allows us to inject extra depenencies for standard EUMM targets
+
+require File::Spec;
+my $dir = File::Spec->catdir(qw(maint .Generated_Pod));
+my $r_fn = File::Spec->catfile($dir, 'README');
+
+my $start_file = sub {
+ my $fn = $mm_proto->quote_literal(shift);
+ return join "\n",
+ qq{\t\$(NOECHO) \$(RM_F) $fn},
+ ( map { qq(\t\$(NOECHO) \$(ECHO) "$_" >> $fn) } (
+ "DBIx::Class is Copyright (c) 2005-@{[ (gmtime)[5] + 1900 ]} by mst, castaway, ribasushi, and others.",
+ "See AUTHORS and LICENSE included with this distribution. All rights reserved.",
+ "",
+ )),
+ ;
+};
+
+postamble <<"EOP";
+
+clonedir_generate_files : dbic_clonedir_gen_readme
+
+dbic_clonedir_gen_readme : dbic_distdir_gen_dbic_pod
+@{[ $start_file->($r_fn) ]}
+\tpod2text $dir/lib/DBIx/Class.pod >> $r_fn
+
+create_distdir : dbic_distdir_regen_license
+
+dbic_distdir_regen_license :
+@{[ $start_file->( File::Spec->catfile( Meta->name . '-' . Meta->version, 'LICENSE') ) ]}
+\t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} LICENSE >> \$(DISTVNAME)/LICENSE
+
+EOP
+
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+# we will be outputting *ENCODED* utf8, hence the raw open below
+# the file is already sanity-checked by xt/authors.t
+my @known_authors = do {
+ open (my $fh, '<:raw', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n";
+ map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>;
+} or die "Known AUTHORS file seems empty... can't happen...";
+
+$_ =~ s!^ ( [^\:]+ ) : \s !B<$1>: !x
+ for @known_authors;
+
+$_ =~ s!( \b https? :// [^\s\>]+ )!L<$1|$1>!x
+ for @known_authors;
+
+print join "\n\n",
+ '=encoding utf8',
+ '=over',
+ @known_authors,
+ '=back',
+ '',
+;
+
+1;
use warnings;
use strict;
+use DBIx::Class::_Util; # load early in case any shims are needed
+
my $lib_dir = 'lib';
my $pod_dir = 'maint/.Generated_Pod';
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Config;
+use Term::ANSIColor ':constants';
+my $CRST = RESET;
+my $CCODE = BOLD;
+my $CSTAT = BOLD . GREEN;
+my $CCORE = BOLD . CYAN;
+my $CSIG = CYAN;
+
+if (@ARGV) {
+ my $code = system (@ARGV);
+
+ if ($code < 0) {
+ exit 127;
+ }
+ elsif ($code > 0) {
+
+ my $status = $code >> 8;
+ my $signum = $code & 127;
+ my $core = $code & 128;
+
+ my %sig_idx;
+ @sig_idx{split /\s+/, $Config{sig_num}} = split /\s/, $Config{sig_name};
+
+ printf STDERR (
+<<EOF
+
+Results of execution: `%s`
+----------------------
+System exit code:$CCODE %d $CRST$CSIG %s $CRST
+ ($CSTAT%08b$CRST$CCORE%b$CRST$CSIG%07b$CRST)
+
+Status: %3s ($CSTAT%08b$CRST)
+Signal: %3s ($CSIG%08b$CRST)
+Core: %3s
+----------------------
+EOF
+ , (join ' ', @ARGV),
+ $code, ($signum ? "(SIG-$sig_idx{$signum})" : ''),
+ $status, $core, $signum,
+ ($status) x 2,
+ ($signum) x 2,
+ ($core ? 'Yes': 'No')
+ );
+
+ exit ($status);
+ }
+}
--- /dev/null
+[remote "ghpr"]
+ url = https://github.com/dbsrgits/DBIx-Class
+ pushurl = DISALLOWED
+ fetch = +refs/pull/*/head:refs/remotes/ghpr/*
+
+[remote "historic"]
+ url = git://git.shadowcat.co.uk/dbsrgits/DBIx-Class-Historic.git
+ pushurl = ssh://dbsrgits@git.shadowcat.co.uk/DBIx-Class-Historic.git
+ fetch = +refs/heads/*:refs/remotes/historic/*
+
+[remote "debian"]
+ url = git://anonscm.debian.org/pkg-perl/packages/libdbix-class-perl.git
+ pushurl = DISALLOWED
+ fetch = +refs/heads/master:refs/remotes/debian/master
+ tagopt = --no-tags
+
+[alias]
+ # Lines after gitk in order:
+ #
+ # --exclude all refs matching the for loop
+ # all known refs (branches/tags) excepth what we excluded
+ # add all individual stashes
+ # add all github PR heads without a matching historic/ghpr/* entry
+ #
+ # the /bin/true at the end is there to eat away any args to 'vis'
+ # ( otherwise they will be treated as commands to execute after the & )
+ vis = "!gitk \
+ $( for r in historic/ghpr ghpr debian ; do echo "--exclude=refs/remotes/$r/*" ; done ) \
+ --all \
+ $(git stash list | cut -f 1 -d ':') \
+ $(/bin/bash -c \"/usr/bin/comm -23 \
+ <(git for-each-ref --sort=objectname --format='%(objectname:short)' refs/remotes/ghpr/ ) \
+ <(git for-each-ref --sort=objectname --format='%(objectname:short)' refs/remotes/historic/ghpr/ refs/remotes/origin/ ) \
+ \") \
+ \"$@\" & /bin/true"
+
+
+ # same but only for GitHub PRs
+ prvis = "!gitk \
+ $(/bin/bash -c \"/usr/bin/comm -23 \
+ <(git for-each-ref --sort=objectname --format='%(objectname:short)' refs/remotes/ghpr/ ) \
+ <(git for-each-ref --sort=objectname --format='%(objectname:short)' refs/remotes/historic/ghpr/ refs/remotes/origin/ ) \
+ \") \
+ \"$@\" & /bin/true"
#!/bin/bash
-source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
+export SHORT_CIRCUIT_SMOKE
+
+if have_sudo ; then
-# Different boxes we run on may have different amount of hw threads
-# Hence why we need to query
-# Originally we used to read /sys/devices/system/cpu/online
-# but it is not available these days (odd). Thus we fall to
-# the alwas-present /proc/cpuinfo
-# The oneliner is a tad convoluted - basicaly what we do is
-# slurp the entire file and get the index off the last
-# `processor : XX` line
-export NUMTHREADS="$(( $(perl -0777 -n -e 'print (/ (?: .+ ^ processor \s+ : \s+ (\d+) ) (?! ^ processor ) /smx)' < /proc/cpuinfo) + 1 ))"
+ # Stop pre-started RDBMS, move their data back to disk (save RAM)
+ # sync for some settle time (not available on all platforms)
+ for d in mysql postgresql ; do
+ # maybe not even running
+ run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true"
+
+ # no longer available on newer build systems
+ if [[ -d /var/ramfs/$d ]] ; then
+ sudo rm -rf /var/lib/$d
+ sudo mv /var/ramfs/$d /var/lib/
+ sudo ln -s /var/lib/$d /var/ramfs/$d
+ fi
+ done
+ /bin/sync
+fi
-export CACHE_DIR="/tmp/poormanscache"
+# Sanity check VM before continuing
+echo "
+=============================================================================
+
+= Startup Meminfo
+$(free -m -t)
+
+============================================================================="
+
+CI_VM_MIN_FREE_MB=2000
+if [[ "$(free -m | grep 'buffers/cache:' | perl -p -e '$_ = (split /\s+/, $_)[3]')" -lt "$CI_VM_MIN_FREE_MB" ]]; then
+ SHORT_CIRCUIT_SMOKE=1
+ echo_err "
+=============================================================================
+
+CI virtual machine stuck in a state with a lot of memory locked for no reason.
+Under Travis this state usually results in a failed build.
+Short-circuiting buildjob to avoid false negatives, please restart it manually.
+
+============================================================================="
+
+# pull requests are always scrutinized after the fact anyway - run a
+# a simpler matrix
+elif [[ "$TRAVIS_PULL_REQUEST" != "false" ]]; then
+ if [[ -n "$BREWVER" ]]; then
+ # just don't brew anything
+ SHORT_CIRCUIT_SMOKE=1
+ else
+ # running PRs with 1 thread is non-sensical
+ VCPU_USE=""
+ fi
+fi
-# install some common tools from APT, more below unless CLEANTEST
-apt_install libapp-nopaste-perl tree apt-transport-https
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
+
+# Previously we were going off the OpenVZ vcpu count and dividing by 3
+# With the new infrastructure, somply go with "something high"
+export VCPU_AVAILABLE=10
+
+if [[ -z "$VCPU_USE" ]] ; then
+ export VCPU_USE="$VCPU_AVAILABLE"
+fi
-# FIXME - the debian package is oddly broken - uses a bin/env based shebang
-# so nothing works under a brew. Fix here until #debian-perl patches it up
-sudo /usr/bin/perl -p -i -e 's|#!/usr/bin/env perl|#!/usr/bin/perl|' $(which nopaste)
if [[ "$CLEANTEST" != "true" ]]; then
-### apt-get invocation - faster to grab everything at once
+
+ if [[ -z "$(tail -n +2 /proc/swaps)" ]] ; then
+ run_or_err "Configuring swap (for Oracle)" \
+ "sudo bash -c 'dd if=/dev/zero of=/swap.img bs=256M count=5 && chmod 600 /swap.img && mkswap /swap.img && swapon /swap.img'"
+ fi
+
+ export CACHE_DIR="/tmp/poormanscache"
+
#
# FIXME these debconf lines should automate the firebird config but do not :(((
sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/enabled\tboolean\ttrue" | debconf-set-selections'
sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/sysdba_password/new_password\tpassword\t123" | debconf-set-selections'
- # add extra APT repo for Oracle
- # (https is critical - apt-get update can't seem to follow the 302)
- sudo bash -c 'echo -e "\ndeb [arch=i386] https://oss.oracle.com/debian unstable main non-free" >> /etc/apt/sources.list'
+ # these APT sources do not mean anything to us anyway
+ sudo rm -rf /etc/apt/sources.list.d/*
+
+ # the actual package is built for lucid, installs fine on both precise and trusty
+ sudo bash -c 'echo "deb http://archive.canonical.com/ubuntu precise partner" >> /etc/apt/sources.list'
- run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --branch=poor_mans_travis_cache https://github.com/ribasushi/travis_futzing.git $CACHE_DIR && $CACHE_DIR/reassemble"
+ # never installed, this looks like trusty
+ if [[ ! -d /var/lib/mysql ]] ; then
+ sudo dpkg --add-architecture i386
+ extra_debs="$extra_debs postgresql mysql-server"
+ fi
- run_or_err "Priming up the APT cache with $(echo $(ls -d $CACHE_DIR/apt_cache/*.deb))" "sudo cp $CACHE_DIR/apt_cache/*.deb /var/cache/apt/archives"
+ # FIXME - by default db2 eats too much memory, we won't be able to test on legacy infra
+ # someone needs to add a minimizing configuration akin to 9367d187
+ if [[ "$(free -m | grep 'Mem:' | perl -p -e '$_ = (split /\s+/, $_)[1]')" -gt 4000 ]] ; then
+ extra_debs="$extra_debs db2exc"
+ fi
- apt_install memcached firebird2.5-super firebird2.5-dev unixodbc-dev expect oracle-xe
+ run_or_err "Updating APT sources" "sudo apt-get update"
+
+ apt_install $extra_debs libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev expect
+
+ # needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!)
+ # for more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links()
+ apt_install unixodbc-dev
+
+ # need to stop them again, in case we installed them above (trusty)
+ for d in mysql postgresql ; do
+ run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true"
+ done
+
+ run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --single-branch --branch=oracle/10.2.0 https://github.com/poormanscache/poormanscache.git $CACHE_DIR && $CACHE_DIR/reassemble"
+ run_or_err "Installing OracleXE manually from deb" \
+ "sudo dpkg -i $CACHE_DIR/apt_cache/bc-multiarch-travis_1.0_all.deb $CACHE_DIR/apt_cache/oracle-xe_10.2.0.1-1.1_i386.deb || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'"
### config memcached
run_or_err "Starting memcached" "sudo /etc/init.d/memcached start"
export DBICTEST_MEMCACHED=127.0.0.1:11211
### config mysql
- run_or_err "Creating MySQL TestDB" "mysql -e 'create database dbic_test;'"
+ run_or_err "Installing minimizing MySQL config" "\
+ sudo bash -c 'rm /var/lib/mysql/ib*' \
+ && sudo cp maint/travis-ci_scripts/configs/minimal_mysql_travis.cnf /etc/mysql/conf.d/ \
+ && sudo chmod 644 /etc/mysql/conf.d/*.cnf \
+ "
+
+ run_or_err "Starting MySQL" "sudo /etc/init.d/mysql start"
+ run_or_err "Creating MySQL TestDB" "mysql -u root -e 'create database dbic_test;'"
export DBICTEST_MYSQL_DSN='dbi:mysql:database=dbic_test;host=127.0.0.1'
export DBICTEST_MYSQL_USER=root
### config pg
+ run_or_err "Starting PostgreSQL" "sudo /etc/init.d/postgresql start"
run_or_err "Creating PostgreSQL TestDB" "psql -c 'create database dbic_test;' -U postgres"
export DBICTEST_PG_DSN='dbi:Pg:database=dbic_test;host=127.0.0.1'
export DBICTEST_PG_USER=postgres
send "\177\177\177\177yes\r"
expect "Password for SYSDBA"
send "123\r"
- sleep 1
+ sleep 2
expect eof
'
# creating testdb
# FIXME - this step still fails from time to time >:(((
# has to do with the FB reconfiguration I suppose
# for now if it fails twice - simply skip FB testing
- for i in 1 2 ; do
+ for i in 1 2 3 ; do
run_or_err "Re-configuring Firebird" "
sync
+ sleep 5
DEBIAN_FRONTEND=text sudo expect -c '$EXPECT_FB_SCRIPT'
- sleep 1
- sync
- # restart the server for good measure
- sudo /etc/init.d/firebird2.5-super stop || true
- sleep 1
- sync
- sudo /etc/init.d/firebird2.5-super start
- sleep 1
- sync
"
if run_or_err "Creating Firebird TestDB" \
'"
export ORACLE_HOME="$CACHE_DIR/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0"
+
+### config db2exc
+ # we may have skipped installation due to low memory
+ if dpkg -l db2exc &>/dev/null ; then
+ # WTF is this world-writable?
+ # Strip the write bit so it doesn't trip Ubuntu's symlink-in-/tmp attack mitigation
+ sudo chmod -R o-w ~dasusr1/das
+
+ export DB2_HOME=/opt/ibm/db2/V9.7
+ export DBICTEST_DB2_DSN=dbi:DB2:DATABASE=dbictest
+ export DBICTEST_DB2_USER=db2inst1
+ export DBICTEST_DB2_PASS=abc123456
+
+ run_or_err "Set up DB2 users" \
+ "echo -e '$DBICTEST_DB2_PASS\n$DBICTEST_DB2_PASS' | sudo passwd $DBICTEST_DB2_USER"
+
+ run_or_err "Create DB2 database" \
+ "sudo -u $DBICTEST_DB2_USER -i db2 'CREATE DATABASE dbictest' && sudo -u $DBICTEST_DB2_USER -i db2 'ACTIVATE DATABASE dbictest'"
+ fi
+
fi
#!/bin/bash
-source maint/travis-ci_scripts/common.bash
if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
-CPAN_MIRROR=$(echo "$PERL_CPANM_OPT" | grep -oP -- '--mirror\s+\S+' | head -n 1 | cut -d ' ' -f 2)
-if ! [[ "$CPAN_MIRROR" =~ "http://" ]] ; then
- echo_err "Unable to extract primary cpan mirror from PERL_CPANM_OPT - something is wrong"
- echo_err "PERL_CPANM_OPT: $PERL_CPANM_OPT"
- CPAN_MIRROR="https://cpan.metacpan.org/"
- PERL_CPANM_OPT="$PERL_CPANM_OPT --mirror $CPAN_MIRROR"
- echo_err "Using $CPAN_MIRROR for the time being"
-fi
+# we need a mirror that both has the standard index and a backpan version rolled
+# into one, due to MDV testing
+CPAN_MIRROR="http://cpan.metacpan.org/"
+
+PERL_CPANM_OPT="$PERL_CPANM_OPT --mirror $CPAN_MIRROR"
-export PERL_MM_USE_DEFAULT=1 PERL_MM_NONINTERACTIVE=1 PERL_AUTOINSTALL_PREFER_CPAN=1 PERLBREW_CPAN_MIRROR="$CPAN_MIRROR" HARNESS_TIMER=1 MAKEFLAGS="-j$NUMTHREADS"
+# do not set PERLBREW_CPAN_MIRROR - not all backpan-like mirrors have the perl tarballs
+export PERL_MM_USE_DEFAULT=1 PERL_MM_NONINTERACTIVE=1 PERL_AUTOINSTALL_PREFER_CPAN=1 HARNESS_TIMER=1 MAKEFLAGS="-j$VCPU_USE"
# try CPAN's latest offering if requested
if [[ "$DEVREL_DEPS" == "true" ]] ; then
PERL_CPANM_OPT="$PERL_CPANM_OPT --dev"
- # FIXME inline-upgrade cpanm, work around https://github.com/travis-ci/travis-ci/issues/1477
- cpanm_loc="$(which cpanm)"
- run_or_err "Upgrading cpanm ($cpanm_loc) to latest stable" \
- "wget -q -O $cpanm_loc cpanmin.us && chmod a+x $cpanm_loc"
fi
# Fixup CPANM_OPT to behave more like a traditional cpan client
export PERL_CPANM_OPT="--verbose --no-interactive --no-man-pages $( echo $PERL_CPANM_OPT | sed 's/--skip-satisfied//' )"
if [[ -n "$BREWVER" ]] ; then
+
# since perl 5.14 a perl can safely be built concurrently with -j$large
# (according to brute force testing and my power bill)
- if [[ "$BREWVER" == "blead" ]] || perl -Mversion -e "exit !!(version->new(q($BREWVER)) < 5.014)" ; then
- perlbrew_jopt="$NUMTHREADS"
+ if [[ "$BREWVER" =~ [A-Za-z] ]] || perl -Mversion -e "exit !!(version->new(q($BREWVER)) < 5.014)" ; then
+ perlbrew_jopt="$VCPU_USE"
+ fi
+
+ BREWSRC="$BREWVER"
+
+ if [[ "$BREWVER" == "schmorp_stableperl" ]] ; then
+ BREWSRC="http://stableperl.schmorp.de/dist/stableperl-5.22.0-1.001.tar.gz"
fi
run_or_err "Compiling/installing Perl $BREWVER (without testing, using ${perlbrew_jopt:-1} threads, may take up to 5 minutes)" \
- "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWVER"
+ "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWSRC"
# can not do 'perlbrew uss' in the run_or_err subshell above, or a $()
# furthermore `perlbrew use` returns 0 regardless of whether the perl is
# no brewver - this means a travis perl, which means we want to clean up
# the presently installed libs
-# Idea stolen from
-# https://github.com/kentfredric/Dist-Zilla-Plugin-Prereqs-MatchInstalled-All/blob/master/maint-travis-ci/sterilize_env.pl
elif [[ "$CLEANTEST" == "true" ]] && [[ "$POISON_ENV" != "true" ]] ; then
-
- echo_err "$(tstamp) Cleaning precompiled Travis-Perl"
- perl -MConfig -MFile::Find -e '
- my $sitedirs = {
- map { $Config{$_} => 1 }
- grep { $_ =~ /site(lib|arch)exp$/ }
- keys %Config
- };
- find({ bydepth => 1, no_chdir => 1, follow_fast => 1, wanted => sub {
- ! $sitedirs->{$_} and ( -d _ ? rmdir : unlink )
- } }, keys %$sitedirs )
- '
-
- echo_err "Post-cleanup contents of sitelib of the pre-compiled Travis-Perl $TRAVIS_PERL_VERSION:"
- echo_err "$(tree $(perl -MConfig -e 'print $Config{sitelib_stem}'))"
- echo_err
+ purge_sitelib
fi
# configure CPAN.pm - older versions go into an endless loop
CPAN::Config->commit;
"
run_or_err "Configuring CPAN.pm" "perl -e '$CPAN_CFG_SCRIPT'"
+
+
+# These envvars are always set, more *maybe* below
+export DBIC_SHUFFLE_UNORDERED_RESULTSETS=1
+
+# bogus nonexisting DBI_*
+export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress"
+export DBI_DRIVER="ADO"
+
+# some people do in fact set this - boggle!!!
+# it of course won't work before 5.8.4
+if perl -M5.008004 -e 1 &>/dev/null ; then
+ export PERL_STRICTURES_EXTRA=1
+fi
+
+
+# poison the environment
+if [[ "$POISON_ENV" = "true" ]] ; then
+
+ # look through lib, find all mentioned DBIC* ENVvars and set them to true and see if anything explodes
+ toggle_booleans=( $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) )
+
+ # some extra pollutants
+ toggle_booleans+=( \
+ DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION \
+ DBICTEST_SQLITE_USE_FILE \
+ DBICTEST_RUN_ALL_TESTS \
+ DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \
+ )
+
+ # if we have Moose - try to run everything under replicated
+ # FIXME - when switching to Moo kill this
+ if [[ "$CLEANTEST" != "true" ]] && perl -M5.008003 -e 1 &>/dev/null ; then
+ toggle_booleans+=( DBICTEST_VIA_REPLICATED )
+ fi
+
+ for var in "${toggle_booleans[@]}"
+ do
+ if [[ -z "${!var}" ]] ; then
+ export $var=1
+ echo "POISON_ENV: setting $var to 1"
+ fi
+ done
+
+
+### emulate a local::lib-like env
+ # trick cpanm into executing true as shell - we just need the find+unpack
+ run_or_err "Downloading latest stable DBIC from CPAN" \
+ "SHELL=/bin/true cpanm --look DBIx::Class"
+
+ # move it somewhere as following cpanm will clobber it
+ run_or_err "Moving latest stable DBIC from CPAN to /tmp" "mv ~/.cpanm/latest-build/DBIx-Class-*/lib /tmp/stable_dbic_lib"
+
+ export PERL5LIB="/tmp/stable_dbic_lib:$PERL5LIB"
+
+ # perldoc -l <mod> searches $(pwd)/lib in addition to PERL5LIB etc, hence the cd /
+ echo_err "Latest stable DBIC (without deps) locatable via \$PERL5LIB at $(cd / && perldoc -l DBIx::Class)"
+
+fi
+
+if [[ "$CLEANTEST" != "true" ]] ; then
+ # using SQLT if will be available
+ # not doing later because we will be running in a subshell
+ export DBICTEST_SQLT_DEPLOY=1
+
+fi
+
+# FIXME - work around https://github.com/miyagawa/cpanminus/issues/462
+# seriously...
+perl -p -i -e 's/\blocal\$self->\{notest\}=1;//' $(which cpanm)
#!/bin/bash
+# this file is executed in a subshell - set up the common stuff
source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
-# poison the environment
-if [[ "$POISON_ENV" = "true" ]] ; then
-
- # look through lib, find all mentioned ENVvars and set them
- # to true and see if anything explodes
- for var in $(grep -P '\$ENV\{' -r lib/ | grep -oP 'DBIC_\w+' | sort -u | grep -v DBIC_TRACE) ; do
- if [[ -z "${!var}" ]] ; then
- export $var=1
- fi
- done
-
- # bogus nonexisting DBI_*
- export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress"
- export DBI_DRIVER="ADO"
-
- # make sure tests do not rely on implicid order of returned results
- export DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER=1
-
- # emulate a local::lib-like env
- # trick cpanm into executing true as shell - we just need the find+unpack
- run_or_err "Downloading latest stable DBIC from CPAN" \
- "SHELL=/bin/true cpanm --look DBIx::Class"
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi
- export PERL5LIB="$( ls -d ~/.cpanm/latest-build/DBIx-Class-*/lib | tail -n1 ):$PERL5LIB"
+# The prereq-install stage will not work with both POISON and DEVREL
+# DEVREL wins
+if [[ "$DEVREL_DEPS" = "true" ]] ; then
+ export POISON_ENV=""
+fi
- # perldoc -l <mod> searches $(pwd)/lib in addition to PERL5LIB etc, hence the cd /
- echo_err "Latest stable DBIC (without deps) locatable via \$PERL5LIB at $(cd / && perldoc -l DBIx::Class)"
+# FIXME - this is a kludge in place of proper MDV testing. For the time
+# being simply use the minimum versions of our DBI/DBDstack, to avoid
+# fuckups like 0.08260 (went unnoticed for 5 months)
+if [[ "$POISON_ENV" = "true" ]] ; then
- # FIXME - this is a kludge in place of proper MDV testing. For the time
- # being simply use the minimum versions of our DBI/DBDstack, to avoid
- # fuckups like 0.08260 (went unnoticed for 5 months)
- #
# use url-spec for DBI due to https://github.com/miyagawa/cpanminus/issues/328
- if perl -M5.013003 -e1 &>/dev/null ; then
+ if [[ "$CLEANTEST" != "true" ]] || perl -M5.013003 -e1 &>/dev/null ; then
+ # the fulltest may re-upgrade DBI, be conservative only on cleantests
# earlier DBI will not compile without PERL_POLLUTE which was gone in 5.14
parallel_installdeps_notest T/TI/TIMB/DBI-1.614.tar.gz
else
fi
# Test both minimum DBD::SQLite and minimum BigInt SQLite
+ # reverse the logic from above for this (low on full, higher on clean)
if [[ "$CLEANTEST" = "true" ]]; then
parallel_installdeps_notest DBD::SQLite@1.37
else
parallel_installdeps_notest DBD::SQLite@1.29
fi
+ # also try minimal tested installs *without* a compiler
+ if [[ "$CLEANTEST" = "true" ]]; then
+
+ # Clone and P::S::XS are both bugs
+ # File::Spec can go away as soon as I dump Path::Class
+ # File::Path is there because of RT#107392 (sigh)
+ # List::Util can be excised after that as well (need to make my own max() routine for older perls)
+
+ installdeps Sub::Name Clone Package::Stash::XS \
+ $( perl -MFile::Spec\ 3.26 -e1 &>/dev/null || echo "File::Path File::Spec" ) \
+ $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" )
+
+ mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist
+ run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \
+ "ln -s /bin/false $HOME/bin/cc"
+ fi
fi
if [[ "$CLEANTEST" = "true" ]]; then
# So instead we still use our stock (possibly old) CPAN, and add some
# handholding
- if [[ "$DEVREL_DEPS" == "true" ]] ; then
- # Many dists still do not pass tests under tb1.5 properly (and it itself
- # does not even install on things like 5.10). Install the *stable-dev*
- # latest T::B here, so that it will not show up as a dependency, and
- # hence it will not get installed a second time as an unsatisfied dep
- # under cpanm --dev
- #
- # We are also not "quite ready" for SQLA 1.99, do not consider it
- #
- installdeps 'Test::Builder~<1.005' 'SQL::Abstract~<1.99'
-
+ if [[ "$DEVREL_DEPS" = "true" ]] ; then
+ # nothing for now
+ /bin/true
elif ! CPAN_is_sane ; then
# no configure_requires - we will need the usual suspects anyway
- # without pre-installing these in one pass things like extract_prereqs won't work
- installdeps ExtUtils::MakeMaker ExtUtils::CBuilder Module::Build
-
+ # without pre-installing these in one pass things won't yet work
+ installdeps Module::Build
fi
else
# we will be running all dbic tests - preinstall lots of stuff, run basic tests
- # using SQLT and set up whatever databases necessary
- export DBICTEST_SQLT_DEPLOY=1
-
- # FIXME - need new TB1.5 devrel
- # if we run under --dev install latest github of TB1.5 first
- # (unreleased workaround for precedence warnings)
- if [[ "$DEVREL_DEPS" == "true" ]] ; then
- parallel_installdeps_notest git://github.com/nthykier/test-more.git@fix-return-precedence-issue
- fi
# do the preinstall in several passes to minimize amount of cross-deps installing
# multiple times, and to avoid module re-architecture breaking another install
# (e.g. once Carp is upgraded there's no more Carp::Heavy,
# while a File::Path upgrade may cause a parallel EUMM run to fail)
#
- parallel_installdeps_notest ExtUtils::MakeMaker
parallel_installdeps_notest File::Path
parallel_installdeps_notest Carp
parallel_installdeps_notest Module::Build
- parallel_installdeps_notest File::Spec Data::Dumper Module::Runtime
+ parallel_installdeps_notest File::Spec Module::Runtime
parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal
parallel_installdeps_notest Test::Warn B::Hooks::EndOfScope Test::Differences HTTP::Status
parallel_installdeps_notest Test::Pod::Coverage Test::EOL Devel::GlobalDestruction Sub::Name MRO::Compat Class::XSAccessor URI::Escape HTML::Entities
- parallel_installdeps_notest YAML LWP Class::Trigger JSON::XS DateTime::Format::Builder Class::Accessor::Grouped Package::Variant
- parallel_installdeps_notest 'SQL::Abstract~<1.99' Moose Module::Install JSON SQL::Translator File::Which
+ parallel_installdeps_notest YAML LWP Class::Trigger DateTime::Format::Builder Class::Accessor::Grouped Package::Variant
+ parallel_installdeps_notest SQL::Abstract Moose Module::Install@1.15 JSON SQL::Translator File::Which Class::DBI::Plugin git://github.com/dbsrgits/perl-pperl.git
+ # the official version is very much outdated and does not compile on 5.14+
+ # use this rather updated source tree (needs to go to PAUSE):
+ # https://github.com/pilcrow/perl-dbd-interbase
if [[ -n "$DBICTEST_FIREBIRD_INTERBASE_DSN" ]] ; then
- # the official version is very much outdated and does not compile on 5.14+
- # use this rather updated source tree (needs to go to PAUSE):
- # https://github.com/pilcrow/perl-dbd-interbase
parallel_installdeps_notest git://github.com/dbsrgits/perl-dbd-interbase.git
fi
+ # SCGI does not install under < 5.8.8 perls nor under parallel make
+ # FIXME: The 5.8.8 thing is likely fixable, something to do with
+ # #define speedy_new(s,n,t) Newx(s,n,t)
+ if perl -M5.008008 -e 1 &>/dev/null ; then
+ MAKEFLAGS="" bash -c "parallel_installdeps_notest git://github.com/dbsrgits/cgi-speedycgi.git"
+ fi
fi
# generate the makefile which will have different deps depending on
# install (remaining) dependencies, sometimes with a gentle push
if [[ "$CLEANTEST" = "true" ]]; then
- # we may need to prepend some stuff to that list
- HARD_DEPS="$(echo $(make listdeps))"
-
-##### TEMPORARY WORKAROUNDS needed in case we will be using CPAN.pm
- if [[ "$DEVREL_DEPS" != "true" ]] && ! CPAN_is_sane ; then
- # combat dzillirium on harness-wide level, otherwise breakage happens weekly
- echo_err "$(tstamp) Ancient CPAN.pm: engaging TAP::Harness::IgnoreNonessentialDzilAutogeneratedTests during dep install"
- perl -MTAP::Harness\ 3.18 -e1 &>/dev/null || run_or_err "Upgrading TAP::Harness for HARNESS_SUBCLASS support" "cpan TAP::Harness"
- export PERL5LIB="$(pwd)/maint/travis-ci_scripts/lib:$PERL5LIB"
- export HARNESS_SUBCLASS="TAP::Harness::IgnoreNonessentialDzilAutogeneratedTests"
- # sanity check, T::H does not report sensible errors when the subclass fails to load
- perl -MTAP::Harness::IgnoreNonessentialDzilAutogeneratedTests -e1
-
- # DBD::SQLite reasonably wants DBI at config time
- perl -MDBI -e1 &>/dev/null || HARD_DEPS="DBI $HARD_DEPS"
-
- # this is a fucked CPAN - won't understand configure_requires of
- # various pieces we may run into
- # FIXME - need to get these off metacpan or something instead
- HARD_DEPS="ExtUtils::Depends B::Hooks::OP::Check $HARD_DEPS"
-
- # FIXME
- # parent is temporary due to Carp https://rt.cpan.org/Ticket/Display.html?id=88494
- HARD_DEPS="parent $HARD_DEPS"
-
- if CPAN_supports_BUILDPL ; then
- # We will invoke a posibly MBT based BUILD-file, but we do not support
- # configure requires. So we not only need to install MBT but its prereqs
- # FIXME This is madness
- HARD_DEPS="$(extract_prereqs Module::Build::Tiny) Module::Build::Tiny $HARD_DEPS"
- else
- # FIXME
- # work around Params::Validate not having a Makefile.PL so really old
- # toolchains can not figure out what the prereqs are ;(
- # Need to do more research before filing a bug requesting Makefile inclusion
- HARD_DEPS="$(extract_prereqs Params::Validate) $HARD_DEPS"
- fi
- fi
-##### END TEMPORARY WORKAROUNDS
- installdeps $HARD_DEPS
+ # we are doing a devrel pass - try to upgrade *everything* (we will be using cpanm so safe-ish)
+ if [[ "$DEVREL_DEPS" == "true" ]] ; then
+
+ HARD_DEPS="$(make listalldeps | sort -R)"
+
+ else
+
+ HARD_DEPS="$(make listdeps | sort -R)"
+
+##### TEMPORARY WORKAROUNDS needed in case we will be using a fucked CPAN.pm
+ if ! CPAN_is_sane ; then
+
+ # DBD::SQLite reasonably wants DBI at config time
+ perl -MDBI -e1 &>/dev/null || HARD_DEPS="DBI $HARD_DEPS"
-### FIXME in case we set it earlier in a workaround
- if [[ -n "$HARNESS_SUBCLASS" ]] ; then
-
- INSTALLDEPS_SKIPPED_TESTLIST=$(perl -0777 -e '
-my $curmod_re = qr{
-^
- (?:
- \QBuilding and testing\E
- |
- [\x20\t]* CPAN\.pm: [^\n]*? (?i:build)\S*
- )
-
- [\x20\t]+ (\S+)
-$}mx;
-
-my $curskip_re = qr{^ === \x20 \QSkipping nonessential autogenerated tests: \E([^\n]+) }mx;
-
-my (undef, @chunks) = (split qr/$curmod_re/, <>);
-while (@chunks) {
- my ($mod, $log) = splice @chunks, 0, 2;
- print "!!! Skipped nonessential tests while installing $mod:\n\t$1\n"
- if $log =~ $curskip_re;
-}
-' <<< "$LASTOUT")
-
- if [[ -n "$INSTALLDEPS_SKIPPED_TESTLIST" ]] ; then
- POSTMORTEM="$POSTMORTEM$(
- echo
- echo "The following non-essential tests were skipped during deps installation"
- echo "============================================================="
- echo "$INSTALLDEPS_SKIPPED_TESTLIST"
- echo "============================================================="
- echo
- )"
fi
- unset HARNESS_SUBCLASS
+##### END TEMPORARY WORKAROUNDS
fi
-else
+ installdeps $HARD_DEPS
- # listalldeps is deliberate - will upgrade everything it can find
- # we exclude SQLA specifically, since we do not want to pull
- # in 1.99_xx on bleadcpan runs
- deplist="$(make listalldeps | grep -vP '^(SQL::Abstract)$')"
+else
- # assume MDV on POISON_ENV, do not touch DBI/SQLite
- if [[ "$POISON_ENV" = "true" ]] ; then
- deplist="$(grep -vP '^(DBI|DBD::SQLite)$' <<< "$deplist")"
- fi
+ parallel_installdeps_notest "$(make listdeps | sort -R)"
- parallel_installdeps_notest "$deplist"
fi
echo_err "$(tstamp) Dependency installation finished"
-# this will display list of available versions
-perl Makefile.PL
+
+run_or_err "Re-configure" "perl Makefile.PL"
# make sure we got everything we need
if [[ -n "$(make listdeps)" ]] ; then
exit 1
fi
+if [[ "$CLEANTEST" = "true" ]] && perl -MModule::Build::Tiny -e1 &>/dev/null ; then
+ echo_err "Module::Build::Tiny pulled in during the basic depchain install - this must not happen"
+ exit 1
+fi
# announce what are we running
echo_err "
===================== DEPENDENCY CONFIGURATION COMPLETE =====================
$(tstamp) Configuration phase seems to have taken $(date -ud "@$SECONDS" '+%H:%M:%S') (@$SECONDS)
-= CPUinfo
-$(perl -0777 -p -e 's/.+\n\n(?!\z)//s' < /proc/cpuinfo)
-
-= Meminfo
-$(free -m -t)
-
-= Kernel info
-$(uname -a)
-
-= Network Configuration
-$(ip addr)
-
-= Network Sockets Status
-$(sudo netstat -an46p | grep -Pv '\s(CLOSING|(FIN|TIME|CLOSE)_WAIT.?|LAST_ACK)\s')
-
-= Environment
-$(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC' | LC_ALL=C sort | cat -v)
-
-= Perl in use
-$(perl -V)
-============================================================================="
+$(ci_vm_state_text)"
#!/bin/bash
+# this file is executed in a subshell - set up the common stuff
source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
+
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi
run_harness_tests() {
- local -x HARNESS_OPTIONS=c:j$NUMTHREADS
+ local -x HARNESS_OPTIONS=c:j$VCPU_USE
+ # if we run under docker (! have_sudo) the logic below won't work
+ # it seems as if ulimit acts globally, across the entire OS
+ # and is thus not served properly by a localised `ps xH`
+ if [[ "$VCPU_USE" == 1 ]] && have_sudo ; then
+ ulim=$(( ( $(ps xH | wc -l) - 3 ) + 4 )) # (real count excluding header + ps + wc) + space for ( make + tee + harness + <actual test> )
+ echo_err "$(tstamp) Setting process/thread limit to $ulim"
+ ulimit -u $ulim
+ sleep 5 # needed to settle things down a bit
+ fi
make test 2> >(tee "$TEST_STDERR_LOG")
}
+# announce everything we have on this box
+TRAVIS="" perl -Ilib t/00describe_environment.t >/dev/null
+
TEST_T0=$SECONDS
if [[ "$CLEANTEST" = "true" ]] ; then
echo_err "$(tstamp) Running tests with plain \`make test\`"
run_or_err "Prepare blib" "make pure_all"
run_harness_tests
else
- PROVECMD="prove -lrswj$NUMTHREADS xt t"
+ PROVECMD="prove -lrswj$VCPU_USE xt t"
# FIXME - temporary, until Package::Stash is fixed
if perl -M5.010 -e 1 &>/dev/null ; then
PROVECMD="$PROVECMD -T"
fi
+ # List every single SKIP/TODO when they are visible
+ if [[ "$VCPU_USE" == 1 ]] ; then
+ PROVECMD="$PROVECMD --directives"
+ fi
+
echo_err "$(tstamp) running tests with \`$PROVECMD\`"
$PROVECMD 2> >(tee "$TEST_STDERR_LOG")
fi
TEST_T1=$SECONDS
-if [[ -z "$DBICTRACE" ]] && [[ -z "$POISON_ENV" ]] && [[ -s "$TEST_STDERR_LOG" ]] ; then
+if \
+ [[ -z "$DBIC_TRACE" ]] \
+&& [[ -z "$DBIC_MULTICREATE_DEBUG" ]] \
+&& [[ -z "$DBICTEST_DEBUG_CONCURRENCY_LOCKS" ]] \
+&& [[ -z "$DBICTEST_VERSION_WARNS_INDISCRIMINATELY" ]] \
+&& [[ -s "$TEST_STDERR_LOG" ]] ; then
STDERR_LOG_SIZE=$(wc -l < "$TEST_STDERR_LOG")
# prepend STDERR log
echo
echo "$(tstamp) Testing took a total of $(( $TEST_T1 - $TEST_T0 ))s"
if [[ -n "$INSTALLDEPS_OUT" ]] ; then
- echo "$(tstamp) Full dep install log at $(/usr/bin/nopaste -q -s Shadowcat -d DepInstall <<< "$INSTALLDEPS_OUT")"
+ echo "$(tstamp) Full dep install log at $(/usr/bin/perl /usr/bin/nopaste -q -s Shadowcat -d DepInstall <<< "$INSTALLDEPS_OUT")"
fi
echo
#!/bin/bash
-# !!! Nothing here will be executed !!!
-# The source-line calling this script is commented out in .travis.yml
-
+# this file is executed in a subshell - set up the common stuff
source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
-echo_err "Nothing to do"
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi
-return 0
+if [[ "$(dmesg)" =~ $( echo "\\bOOM\\b" ) ]] ; then
+ echo_err "=== dmesg ringbuffer"
+ echo_err "$(dmesg)"
+fi
#!/bin/bash
+# this file is executed in a subshell - set up the common stuff
source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
-if [[ "$CLEANTEST" != "true" ]] ; then
- parallel_installdeps_notest $(perl -Ilib -MDBIx::Class -e 'print join " ", keys %{DBIx::Class::Optional::Dependencies->req_list_for("dist_dir")}')
- run_or_err "Attempt to build a dist with all prereqs present" "make dist"
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] || [[ "$TRAVIS_PULL_REQUEST" != "false" ]] ; then exit 0 ; fi
+
+# this part needs to run in parallel unconditionally
+export VCPU_USE="$VCPU_AVAILABLE"
+export HARNESS_OPTIONS="j$VCPU_USE"
+
+
+if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then
+ # FIXME - Devel::Cover (brought by Test::Strict, but soon needed anyway)
+ # does not test cleanly on 5.8.7 - just get it directly
+ if perl -M5.008007 -e1 &>/dev/null && ! perl -M5.008008 -e1 &>/dev/null; then
+ parallel_installdeps_notest Devel::Cover
+ fi
+
+ # FIXME - workaround for YAML/RT#81120 and L::SRH/RT#107681
+ # We don't actually need these modules, only there because of SQLT (which will be fixed)
+ # does not test cleanly on 5.8.7 - just get them directly
+ if ! perl -M5.008008 -e1 &>/dev/null; then
+ parallel_installdeps_notest YAML Lexical::SealRequireHints
+ fi
+
+ # FIXME Change when Moose goes away
+ installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir)
+
+ run_or_err "Attempt to build a dist" "rm -rf inc/ && perl Makefile.PL --skip-author-deps && make dist"
+ tarball_assembled=1
+
+elif [[ "$CLEANTEST" != "true" ]] ; then
+ parallel_installdeps_notest $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir)
+
+ run_or_err "Attempt to build a dist from original checkout" "make dist"
+ tarball_assembled=1
+fi
+
+
+if [[ -n "$tarball_assembled" ]] ; then
+
echo "Contents of the resulting dist tarball:"
echo "==========================================="
tar -vzxf DBIx-Class-*.tar.gz
echo "==========================================="
- run_or_err 'Attempt to configure from re-extracted distdir' \
- 'bash -c "cd \$(find DBIx-Class-* -maxdepth 0 -type d | head -n 1) && perl Makefile.PL"'
+
+ # kill as much as possible with fire
+ purge_sitelib
+
+
+ # undo some of the pollution (if any) affecting the plain install deps
+ # FIXME - this will go away once we move off Moose, and a new SQLT
+ # with much less recommends ships
+ export DBICTEST_SQLT_DEPLOY=""
+ export DBICTEST_VIA_REPLICATED=""
+
+
+ # make sure we are retrying with newest CPAN possible
+ #
+ # not running tests on CPAN.pm - they are not terribly slow,
+ # but https://rt.cpan.org/Ticket/Display.html?id=96437 sucks
+ parallel_installdeps_notest CPAN
+ run_or_err "Make sure CPAN was upgraded to at least 2.10" "perl -M'CPAN 2.010' -e1"
+
+ run_or_err "Re-Configuring CPAN.pm" "perl -MCPAN -e '\
+ CPAN::Config->load;
+
+ # For the time being smoking with this setting is not realistic
+ # https://rt.cpan.org/Ticket/Display.html?id=103280
+ # https://rt.cpan.org/Ticket/Display.html?id=37641
+ # https://rt.cpan.org/Ticket/Display.html?id=77708
+ # https://rt.cpan.org/Ticket/Display.html?id=87474
+ #\$CPAN::Config->{build_requires_install_policy} = q{no};
+
+ \$CPAN::Config->{recommends_policy} = q{yes};
+ CPAN::Config->commit;
+ '"
+
+ cd "$(find DBIx-Class-* -maxdepth 0 -type d | head -n 1)"
+
+ # only run a full test cycle on devrel_deps, as they are all marked
+ # as "allow fails" in the travis matrix
+ if [[ "$DEVREL_DEPS" == "true" ]] ; then
+
+ for e in $( env | grep 'DBICTEST.*DSN' | cut -f 1 -d '=' ) ; do
+ echo "Unsetting $e"
+ export $e=""
+ done
+
+ run_or_err \
+ "Attempt to configure/test/build/install dist using latest CPAN@$(perl -MCPAN -e 'print CPAN->VERSION')" \
+ "cpan ."
+
+ else
+ run_or_err \
+ "Attempt to configure/build/install dist using latest CPAN@$(perl -MCPAN -e 'print CPAN->VERSION')" \
+ "perl -MCPAN -e 'notest( install => q{.} )'"
+ fi
fi
#!/bin/bash
# !!! Nothing here will be executed !!!
-# The source-line calling this script is commented out in .travis.yml
+# The line calling this script is commented out in .travis.yml
+# this file is executed in a subshell - set up the common stuff
source maint/travis-ci_scripts/common.bash
-if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
-echo_err "Nothing to do"
+if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi
-return 0
+echo_err "Nothing to do"
#!/bin/bash
+# "autodie"
set -e
TEST_STDERR_LOG=/tmp/dbictest.stderr
-TIMEOUT_CMD="/usr/bin/timeout --kill-after=9.5m --signal=TERM 9m"
+TIMEOUT_CMD="/usr/bin/timeout --kill-after=16m --signal=TERM 15m"
echo_err() { echo "$@" 1>&2 ; }
tstamp() { echo -n "[$(date '+%H:%M:%S')]" ; }
+ci_vm_state_text() {
+ echo "
+========================== CI System information ============================
+
+= CPUinfo
+$(perl -0777 -p -e 's/.+\n\n(?!\z)//s' < /proc/cpuinfo)
+
+= Meminfo
+$(free -m -t)
+
+= Diskinfo
+$(df -h)
+
+$(mount | grep '^/')
+
+= Kernel info
+$(uname -a)
+
+= Network Configuration
+$(ip addr)
+
+= Network Sockets Status
+$( (sudo netstat -an46p || netstat -an46p) | grep -Pv '\s(CLOSING|(FIN|TIME|CLOSE)_WAIT.?|LAST_ACK)\s')
+
+= Processlist
+$(ps fuxa)
+
+= Environment
+$(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC|PATH|SHELL' | LC_ALL=C sort | cat -v)
+
+= Perl in use
+$(perl -V)
+============================================================================="
+}
+
run_or_err() {
echo_err -n "$(tstamp) $1 ... "
+ LASTCMD="$2"
LASTEXIT=0
START_TIME=$SECONDS
# the double bash is to hide the job control messages
bash -c "bash -c 'echo \$\$ >> $PRMETER_PIDFILE; while true; do sleep 10; echo -n \"\${SECONDS}s ... \"; done' &"
- # the tee is a handy debugging tool when stumpage is exceedingly strong
- #LASTOUT=$( bash -c "$2" 2>&1 | tee /dev/stderr) || LASTEXIT=$?
- LASTOUT=$( bash -c "$2" 2>&1 ) || LASTEXIT=$?
+ LASTOUT=$( eval "$2" 2>&1 ) || LASTEXIT=$?
# stop progress meter
for p in $(cat "$PRMETER_PIDFILE"); do kill $p ; done
DELTA_TIME=$(( $SECONDS - $START_TIME ))
if [[ "$LASTEXIT" != "0" ]] ; then
- echo_err "FAILED !!! (after ${DELTA_TIME}s)"
- echo_err "Command executed:"
- echo_err "$2"
- echo_err "STDOUT+STDERR:"
- echo_err "$LASTOUT"
+ if [[ -z "$3" ]] ; then
+ echo_err "FAILED !!! (after ${DELTA_TIME}s)"
+ echo_err "Command executed:"
+ echo_err "$LASTCMD"
+ echo_err "STDOUT+STDERR:"
+ echo_err "$LASTOUT"
+ if [[ "$(dmesg)" =~ $( echo "\\bOOM\\b" ) ]] ; then
+ echo_err "=== dmesg ringbuffer"
+ echo_err "$(dmesg)"
+ fi
+ fi
return $LASTEXIT
else
# flatten
pkgs="$@"
- # Need to do this at every step, the sources list may very well have changed
- run_or_err "Updating APT available package list" "sudo apt-get update"
-
run_or_err "Installing Debian APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs"
}
if [[ -z "$@" ]] ; then return; fi
# one module spec per line
- MODLIST="$(printf '%s\n' "$@")"
+ MODLIST="$(printf '%s\n' "$@" | sort -R)"
# We want to trap the output of each process and serially append them to
# each other as opposed to just dumping a jumbled up mass-log that would
run_or_err "Installing (without testing) $(echo $MODLIST)" \
"echo \\
\"$MODLIST\" \\
- | xargs -d '\\n' -n 1 -P $NUMTHREADS bash -c \\
- 'OUT=\$($TIMEOUT_CMD cpanm --notest \"\$@\" 2>&1 ) || (LASTEXIT=\$?; echo \"\$OUT\"; exit \$LASTEXIT)' \\
+ | xargs -d '\\n' -n 1 -P $VCPU_USE bash -c \\
+ 'OUT=\$(maint/getstatus $TIMEOUT_CMD cpanm --notest \"\$@\" 2>&1 ) || (LASTEXIT=\$?; echo \"\$OUT\"; exit \$LASTEXIT)' \\
'giant space monkey penises'
"
}
+export -f parallel_installdeps_notest run_or_err echo_err tstamp
+
installdeps() {
if [[ -z "$@" ]] ; then return; fi
- echo_err "$(tstamp) Processing dependencies: $@"
+ MODLIST=$(printf "%q " "$@" | perl -pe 's/^\s+|\s+$//g')
local -x HARNESS_OPTIONS
- HARNESS_OPTIONS="j$NUMTHREADS"
-
- echo_err -n "Attempting install of $# modules under parallel ($HARNESS_OPTIONS) testing ... "
+ HARNESS_OPTIONS="j$VCPU_USE"
- LASTEXIT=0
- START_TIME=$SECONDS
- LASTOUT=$( _dep_inst_with_test "$@" ) || LASTEXIT=$?
- DELTA_TIME=$(( $SECONDS - $START_TIME ))
+ if ! run_or_err "Attempting install of $# modules under parallel ($HARNESS_OPTIONS) testing ($MODLIST)" "_dep_inst_with_test $MODLIST" quiet_fail ; then
+ local errlog="failed after ${DELTA_TIME}s Exit:$LASTEXIT Log:$(/usr/bin/perl /usr/bin/nopaste -q -s Shadowcat -d "Parallel testfail" <<< "$LASTOUT")"
+ echo "$errlog"
- if [[ "$LASTEXIT" = "0" ]] ; then
- echo_err "done (took ${DELTA_TIME}s)"
- else
- local errlog="after ${DELTA_TIME}s Exit:$LASTEXIT Log:$(/usr/bin/nopaste -q -s Shadowcat -d "Parallel testfail" <<< "$LASTOUT")"
- echo_err -n "failed ($errlog) retrying with sequential testing ... "
POSTMORTEM="$POSTMORTEM$(
echo
- echo "Depinstall under $HARNESS_OPTIONS parallel testing failed $errlog"
- echo "============================================================="
- echo "Attempted installation of: $@"
- echo "============================================================="
+ echo "Depinstall of $MODLIST under $HARNESS_OPTIONS parallel testing $errlog"
)"
HARNESS_OPTIONS=""
- LASTEXIT=0
- START_TIME=$SECONDS
- LASTOUT=$( _dep_inst_with_test "$@" ) || LASTEXIT=$?
- DELTA_TIME=$(( $SECONDS - $START_TIME ))
-
- if [[ "$LASTEXIT" = "0" ]] ; then
- echo_err "done (took ${DELTA_TIME}s)"
- else
- echo_err "FAILED !!! (after ${DELTA_TIME}s)"
- echo_err "STDOUT+STDERR:"
- echo_err "$LASTOUT"
- exit 1
- fi
+ run_or_err "Retrying same $# modules without parallel testing" "_dep_inst_with_test $MODLIST"
fi
INSTALLDEPS_OUT="${INSTALLDEPS_OUT}${LASTOUT}"
_dep_inst_with_test() {
if [[ "$DEVREL_DEPS" == "true" ]] ; then
# --dev is already part of CPANM_OPT
- $TIMEOUT_CMD cpanm "$@" 2>&1
+ LASTCMD="$TIMEOUT_CMD cpanm $@"
+ $LASTCMD 2>&1 || return 1
else
- $TIMEOUT_CMD cpan "$@" 2>&1
+ LASTCMD="$TIMEOUT_CMD cpan $@"
+ $LASTCMD 2>&1 || return 1
# older perls do not have a CPAN which can exit with error on failed install
for m in "$@"; do
if ! perl -e '
+$ARGV[0] =~ s/-TRIAL\.//;
+
my $mod = (
- $ARGV[0] =~ m{ \/ .*? ([^\/]+) $ }x
+ # abuse backtrack
+ $ARGV[0] =~ m{ / .*? ( [^/]+ ) $ }x
? do { my @p = split (/\-/, $1); pop @p; join "::", @p }
: $ARGV[0]
);
-$mod = q{List::Util} if $mod eq q{Scalar::List::Utils};
+# map some install-names to a module/version combo
+# serves both as a grandfathered title-less tarball, and
+# as a minimum version check for upgraded core modules
+my $eval_map = {
+
+ # this is temporary, will need something more robust down the road
+ # (perhaps by then Module::CoreList will be dep-free)
+ "Module::Build" => { ver => "0.4214" },
+ "podlators" => { mod => "Pod::Man", ver => "2.17" },
+
+ "File::Spec" => { ver => "3.47" },
+ "Cwd" => { ver => "3.47" },
+
+ "List::Util" => { ver => "1.42" },
+ "Scalar::Util" => { ver => "1.42" },
+ "Scalar::List::Utils" => { mod => "List::Util", ver => "1.42" },
+};
+
+my $m = $eval_map->{$mod}{mod} || $mod;
+
+eval(
+ "require $m"
-eval qq{require($mod)} or ( print $@ and exit 1)
+ .
+
+ ($eval_map->{$mod}{ver}
+ ? "; $m->VERSION(\$eval_map->{\$mod}{ver}) "
+ : ""
+ )
+
+ .
+
+ "; 1"
+)
+ or
+( print $@ and exit 1)
' "$m" 2> /dev/null ; then
echo -e "$m installation seems to have failed"
fi
}
+# Idea stolen from
+# https://github.com/kentfredric/Dist-Zilla-Plugin-Prereqs-MatchInstalled-All/blob/master/maint-travis-ci/sterilize_env.pl
+# Only works on 5.12+ (where sitelib was finally properly fixed)
+purge_sitelib() {
+ echo_err "$(tstamp) Sterilizing the Perl installation (cleaning up sitelib)"
+
+ if perl -M5.012 -e1 &>/dev/null ; then
+
+ perl -M5.012 -MConfig -MFile::Find -e '
+ my $sitedirs = {
+ map { $Config{$_} => 1 }
+ grep { $_ =~ /site(lib|arch)exp$/ }
+ keys %Config
+ };
+ find({ bydepth => 1, no_chdir => 1, follow_fast => 1, wanted => sub {
+ ! $sitedirs->{$_} and ( -d _ ? rmdir : unlink )
+ } }, keys %$sitedirs )
+ '
+ else
+
+ cl_fn="/tmp/${TRAVIS_BUILD_ID}_Module_CoreList.pm";
+
+ [[ -s "$cl_fn" ]] || run_or_err \
+ "Downloading latest Module::CoreList" \
+ "curl -s --compress -o '$cl_fn' https://api.metacpan.org/source/Module::CoreList"
+
+ perl -0777 -Ilib -MDBIx::Class::Optional::Dependencies -e '
+
+ # this is horrible, but really all we want is "has this ever been used"
+ # so a grep without a load is quite legit (and horrible)
+ my $mcl_source = <>;
+
+ my @all_possible_never_been_core_modpaths = map
+ { (my $mp = $_ . ".pm" ) =~ s|::|/|g; $mp }
+ grep
+ { $mcl_source !~ / ^ \s+ \x27 $_ \x27 \s* \=\> /mx }
+ (
+ qw(
+ Module::Build::Tiny
+ ),
+ keys %{ DBIx::Class::Optional::Dependencies->modreq_list_for([
+ keys %{ DBIx::Class::Optional::Dependencies->req_group_list }
+ ])}
+ )
+ ;
+
+ # now that we have the list we can go ahead and destroy every single one
+ # of these modules without being concerned about breaking the base ability
+ # to install things
+ for my $mp ( sort { lc($a) cmp lc($b) } @all_possible_never_been_core_modpaths ) {
+ for my $incdir (@INC) {
+ -e "$incdir/$mp"
+ and
+ unlink "$incdir/$mp"
+ and
+ print "Nuking $incdir/$mp\n"
+ }
+ }
+ ' "$cl_fn"
+
+ fi
+}
+
+
CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; }
CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; }
+
+have_sudo() { sudo /bin/true &>/dev/null ; }
--- /dev/null
+[mysqld]
+
+# the DBIC test suite does hold up to 3 concurrent connections
+# (t/94versioning.t), otherwise this could conceivably go lower (~50MB vsize
+# per connection)
+max_connections = 3
+
+thread_cache_size = 0
+thread_stack = 128K
+
+# mysql >= 5.5.16
+#thread_pool_size = 1
+
+net_buffer_length = 4K
+read_buffer_size = 32K
+join_buffer_size = 128K
+sort_buffer_size = 128K
+bulk_insert_buffer_size = 0
+
+table_definition_cache = 256
+performance_schema = 0
+
+query_cache_type = 0
+query_cache_size = 0
+query_cache_limit = 16K
+
+myisam_sort_buffer_size = 16K
+tmp_table_size = 1M
+key_buffer_size = 64K
+
+innodb_data_file_path = ibdata1:10M:autoextend
+innodb_autoextend_increment = 1
+innodb_buffer_pool_size = 512K
+
+innodb_stats_on_metadata = 0
+innodb_file_per_table = 0
+
+innodb_log_file_size = 1M
+innodb_log_buffer_size = 512K
+innodb_buffer_pool_size = 512K
+
+innodb_use_sys_malloc = 0
+innodb_additional_mem_pool_size = 256K
+innodb_flush_method = O_DIRECT
+
+innodb_read_io_threads = 1
+innodb_write_io_threads = 1
+++ /dev/null
-package TAP::Harness::IgnoreNonessentialDzilAutogeneratedTests;
-
-use warnings;
-use strict;
-
-use base 'TAP::Harness';
-use File::Spec ();
-use IPC::Open3 'open3';
-use File::Temp ();
-use List::Util 'first';
-
-my $frivolous_test_map = {
-# Test based on the extremely dep-heavy, *prone to failures* Test::CheckDeps
-#
- qr|^t/00-check-deps.t$| => [
- qr|^\Q# this test was generated with Dist::Zilla::Plugin::Test::CheckDeps|m,
-
- # older non-annotated versions
- qr|use \s+ Test::CheckDeps .*? ^\Qcheck_dependencies('suggests')\E .*? \QBAIL_OUT("Missing dependencies") if !Test::More->builder->is_passing|smx,
- ],
-
-# "does everything compile" tests are useless by definition - this is what the
-# rest of the test suite is for
-#
- qr|^t/00-compile.t$| => [
- qr|^\Q# this test was generated with Dist::Zilla::Plugin::Test::Compile|m,
- ],
-
-# The report prereq test managed to become fatal as well
-#
- qr|^t/00-report-prereqs.t$| => [
- qr|^\Q# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs|m,
- ],
-
-# Just future-proof the thing, catch anything autogened by dzil for a bit
- qr|^t/00-| => [
- qr|^\Q# This test was generated by Dist::Zilla::|m,
- ]
-};
-
-sub aggregate_tests {
- my ($self, $aggregate, @all_tests) = @_;
-
- my ($run_tests, $skip_tests);
-
- TESTFILE:
- for (@all_tests) {
- my $fn = File::Spec::Unix->catpath( File::Spec->splitpath( $_ ) );
-
- if (my $REs = $frivolous_test_map->{
- (first { $fn =~ $_ } keys %$frivolous_test_map ) || ''
- }) {
- my $slurptest = do { local (@ARGV, $/) = $fn; <> };
- $slurptest =~ $_ and push @$skip_tests, $fn and next TESTFILE for @$REs;
- }
-
- push @$run_tests, $fn;
- }
-
- if ($skip_tests) {
-
- for my $tfn (@$skip_tests) {
-
- (my $tfn_flattened = $tfn) =~ s|/|_|g;
-
- my $log_file = File::Temp->new(
- DIR => '/tmp',
- TEMPLATE => "AutoGenTest_${tfn_flattened}_XXXXX",
- SUFFIX => '.txt',
- );
-
- # FIXME I have no idea why the fileno dance is necessary - will investigate later
- # All I know is that if I pass in just $log_file - open3 ignores it >:(
- my $pid = open3(undef, '>&'.fileno($log_file), undef, $^X, qw(-I blib -I arch/lib), $tfn );
- waitpid ($pid, 0);
- my $ex = $?;
-
- if ($ex) {
- # use qx as opposed to another open3 until I figure out the above
- close $log_file or die "Unable to close $log_file: $!";
- chomp( my $url = `/usr/bin/nopaste -q -s Shadowcat -d $log_file < $log_file` );
-
- $tfn .= "[would NOT have passed: $ex / $url]";
- }
- }
-
- print STDERR "=== Skipping nonessential autogenerated tests: @$skip_tests\n";
- }
-
- return $self->SUPER::aggregate_tests($aggregate, @$run_tests);
-}
-
-1;
use warnings;
BEGIN {
- use DBIx::Class;
- die ( 'The following modules are required for the dbicadmin utility: '
- . DBIx::Class::Optional::Dependencies->req_missing_for ('admin_script')
- . "\n"
- ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin_script');
+ require DBIx::Class::Optional::Dependencies;
+ if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('admin_script') ) {
+ die "The following modules are required for the dbicadmin utility: $missing\n";
+ }
}
use DBIx::Class::Admin::Descriptive;
--- /dev/null
+###
+### This version is rather 5.8-centric, because DBIC itself is 5.8
+### It certainly can be rewritten to degrade well on 5.6
+###
+
+# Very important to grab the snapshot early, as we will be reporting
+# the INC indices from the POV of whoever ran the script, *NOT* from
+# the POV of the internals
+my @initial_INC;
+BEGIN {
+ @initial_INC = @INC;
+}
+
+BEGIN {
+ unshift @INC, 't/lib';
+
+ if ( "$]" < 5.010) {
+
+ # Pre-5.10 perls pollute %INC on unsuccesfull module
+ # require, making it appear as if the module is already
+ # loaded on subsequent require()s
+ # Can't seem to find the exact RT/perldelta entry
+ #
+ # The reason we can't just use a sane, clean loader, is because
+ # if a Module require()s another module the %INC will still
+ # get filled with crap and we are back to square one. A global
+ # fix is really the only way for this test, as we try to load
+ # each available module separately, and have no control (nor
+ # knowledge) over their common dependencies.
+ #
+ # we want to do this here, in the very beginning, before even
+ # warnings/strict are loaded
+
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = eval { $_[0]->() };
+ if ($@ ne '') {
+ delete $INC{$_[1]};
+ die $@;
+ }
+ return $res;
+ } );
+ }
+}
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Config;
+use File::Find 'find';
+use Digest::MD5 ();
+use Cwd 'abs_path';
+use File::Spec;
+use List::Util 'max';
+use ExtUtils::MakeMaker;
+
+use DBICTest::RunMode;
+use DBICTest::Util 'visit_namespaces';
+use DBIx::Class::Optional::Dependencies;
+
+my $known_paths = {
+ SA => {
+ config_key => 'sitearch',
+ },
+ SL => {
+ config_key => 'sitelib',
+ },
+ SS => {
+ config_key => 'sitelib_stem',
+ match_order => 1,
+ },
+ SP => {
+ config_key => 'siteprefix',
+ match_order => 2,
+ },
+ VA => {
+ config_key => 'vendorarch',
+ },
+ VL => {
+ config_key => 'vendorlib',
+ },
+ VS => {
+ config_key => 'vendorlib_stem',
+ match_order => 3,
+ },
+ VP => {
+ config_key => 'vendorprefix',
+ match_order => 4,
+ },
+ PA => {
+ config_key => 'archlib',
+ },
+ PL => {
+ config_key => 'privlib',
+ },
+ PP => {
+ config_key => 'prefix',
+ match_order => 5,
+ },
+ BLA => {
+ rel_path => './blib/arch',
+ skip_unversioned_modules => 1,
+ },
+ BLL => {
+ rel_path => './blib/lib',
+ skip_unversioned_modules => 1,
+ },
+ INC => {
+ rel_path => './inc',
+ },
+ LIB => {
+ rel_path => './lib',
+ skip_unversioned_modules => 1,
+ },
+ T => {
+ rel_path => './t',
+ skip_unversioned_modules => 1,
+ },
+ XT => {
+ rel_path => './xt',
+ skip_unversioned_modules => 1,
+ },
+ CWD => {
+ rel_path => '.',
+ },
+ HOME => {
+ rel_path => '~',
+ abs_unix_path => abs_unix_path (
+ eval { require File::HomeDir and File::HomeDir->my_home }
+ ||
+ $ENV{USERPROFILE}
+ ||
+ $ENV{HOME}
+ ||
+ glob('~')
+ ),
+ },
+};
+
+for my $k (keys %$known_paths) {
+ my $v = $known_paths->{$k};
+
+ # never use home as a found-in-dir marker - it is too broad
+ # HOME is only used by the shortener
+ $v->{marker} = $k unless $k eq 'HOME';
+
+ unless ( $v->{abs_unix_path} ) {
+ if ( $v->{rel_path} ) {
+ $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
+ }
+ elsif ( $Config{ $v->{config_key} || '' } ) {
+ $v->{abs_unix_path} = abs_unix_path (
+ $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
+ );
+ }
+ }
+
+ delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
+}
+my $seen_markers = {};
+
+# first run through lib/ and *try* to load anything we can find
+# within our own project
+find({
+ wanted => sub {
+ -f $_ or return;
+
+ # can't just `require $fn`, as we need %INC to be
+ # populated properly
+ my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
+ or return;
+
+ try_module_require(join ('::', File::Spec->splitdir($mod)) )
+ },
+ no_chdir => 1,
+}, 'lib' );
+
+
+
+# now run through OptDeps and attempt loading everything else
+#
+# some things needs to be sorted before other things
+# positive - load first
+# negative - load last
+my $load_weights = {
+ # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
+ # clashes with libssl, and will segfault everything coming after them
+ "DBD::Oracle" => -999,
+};
+
+my @known_modules = sort
+ { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
+ keys %{
+ DBIx::Class::Optional::Dependencies->req_list_for([
+ grep
+ # some DBDs are notoriously problematic to load
+ # hence only show stuff based on test_rdbms which will
+ # take into account necessary ENVs
+ { $_ !~ /^ (?: rdbms | dist )_ /x }
+ keys %{DBIx::Class::Optional::Dependencies->req_group_list}
+ ])
+ }
+;
+
+try_module_require($_) for @known_modules;
+
+my $has_versionpm = eval { require version };
+
+
+# At this point we've loaded everything we ever could, but some modules
+# (understandably) crapped out. For an even more thorough report, note
+# everthing present in @INC we excplicitly know about (via OptDeps)
+# *even though* it didn't load
+my $known_failed_loads;
+
+for my $mod (@known_modules) {
+ my $inc_key = module_notional_filename($mod);
+ next if defined $INC{$inc_key};
+
+ if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
+ $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
+ }
+
+}
+
+my $perl = 'perl';
+
+# This is a cool idea, but the line is too long even with shortening :(
+#
+#for my $i ( 1 .. $Config{config_argc} ) {
+# my $conf_arg = $Config{"config_arg$i"};
+# $conf_arg =~ s!
+# \= (.+)
+# !
+# '=' . shorten_fn($1)
+# !ex;
+#
+# $perl .= " $conf_arg";
+#}
+
+my $interesting_modules = {
+ # pseudo module
+ $perl => {
+ version => $],
+ abs_unix_path => abs_unix_path($^X),
+ }
+};
+
+
+# drill through the *ENTIRE* symtable and build a map of interesting modules
+visit_namespaces( action => sub {
+ no strict 'refs';
+ my $pkg = shift;
+
+ # keep going, but nothing to see here
+ return 1 if $pkg eq 'main';
+
+ # private - not interested, including no further descent
+ return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
+
+ my $inc_key = module_notional_filename($pkg);
+
+ my $abs_unix_path = (
+ $INC{$inc_key}
+ and
+ -f $INC{$inc_key}
+ and
+ -r $INC{$inc_key}
+ and
+ abs_unix_path($INC{$inc_key})
+ );
+
+ # handle versions first (not interested in synthetic classes)
+ if (
+ defined ${"${pkg}::VERSION"}
+ and
+ ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
+ ) {
+
+ # make sure a version can be extracted, be noisy when it doesn't work
+ # do this even if we are throwing away the result below in lieu of EUMM
+ my $mod_ver = eval { $pkg->VERSION };
+
+ if (my $err = $@) {
+ $err =~ s/^/ /mg;
+ say_err (
+ "Calling `$pkg->VERSION` resulted in an exception, which should never "
+ . "happen - please file a bug with the distribution containing $pkg. "
+ . "Complete exception text below:\n\n$err"
+ );
+ }
+ elsif( ! defined $mod_ver or ! length $mod_ver ) {
+ my $ret = defined $mod_ver
+ ? "the empty string ''"
+ : "'undef'"
+ ;
+
+ say_err (
+ "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
+ . "is defined, which should never happen - please file a bug with the "
+ . "distribution containing $pkg."
+ );
+
+ undef $mod_ver;
+ }
+
+ if (
+ $abs_unix_path
+ and
+ defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
+ ) {
+
+ # can only run the check reliably if v.pm is there
+ if (
+ $has_versionpm
+ and
+ defined $mod_ver
+ and
+ $eumm_ver ne $mod_ver
+ and
+ (
+ ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
+ !=
+ ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
+ )
+ ) {
+ say_err (
+ "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
+ . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} "
+ . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
+ . "This should never happen - please check whether this is still present "
+ . "in the latest version, and then file a bug with the distribution "
+ . "containing $pkg."
+ );
+ }
+
+ $interesting_modules->{$pkg}{version} = $eumm_ver;
+ }
+ elsif( defined $mod_ver ) {
+
+ $interesting_modules->{$pkg}{version} = $mod_ver;
+ }
+ }
+ elsif ( $known_failed_loads->{$pkg} ) {
+ $abs_unix_path = $known_failed_loads->{$pkg};
+ $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
+ }
+
+ if ($abs_unix_path) {
+ my ($marker, $initial_inc_idx);
+
+ my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
+ my $p = subpath_of_known_path( $abs_unix_path );
+
+ if (
+ defined $current_inc_idx
+ and
+ $p->{marker}
+ and
+ abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
+ ) {
+ $marker = $p->{marker};
+ }
+ elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
+ $marker = "\$INC[$initial_inc_idx]";
+ }
+
+ # we are only interested if there was a declared version already above
+ # OR if the module came from somewhere other than skip_unversioned_modules
+ if (
+ $marker
+ and
+ (
+ $interesting_modules->{$pkg}
+ or
+ !$p->{skip_unversioned_modules}
+ )
+ ) {
+ $interesting_modules->{$pkg}{source_marker} = $marker;
+ $seen_markers->{$marker} = 1;
+ }
+
+ # at this point only fill in the path (md5 calc) IFF it is interesting
+ # in any respect
+ $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
+ if $interesting_modules->{$pkg};
+ }
+
+ 1;
+});
+
+# compress identical versions sourced from ./blib, ./lib, ./t and ./xt
+# as close to the root of a namespace as we can
+purge_identically_versioned_submodules_with_markers([ map {
+ ( $_->{skip_unversioned_modules} && $_->{marker} ) || ()
+} values %$known_paths ]);
+
+ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
+
+# do not announce anything under ci - we are watching for STDERR silence
+exit 0 if DBICTest::RunMode->is_ci;
+
+
+# diag the result out
+my $max_ver_len = max map
+ { length "$_" }
+ ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
+;
+my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
+
+my $discl = <<'EOD';
+
+List of loadable modules within both the core and *OPTIONAL* dependency chains
+present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt
+with versions identical to their parent namespace were omitted for brevity)
+
+ *** Note that *MANY* of these modules will *NEVER* be loaded ***
+ *** during normal operation of DBIx::Class ***
+EOD
+
+# pre-assemble everything and print it in one shot
+# makes it less likely for parallel test execution to insert bogus lines
+my $final_out = "\n$discl\n";
+
+$final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
+
+my $in_inc_skip;
+for (0.. $#initial_INC) {
+
+ my $shortname = shorten_fn( $initial_INC[$_] );
+
+ # when *to* print a line of INC
+ if (
+ ! $ENV{AUTOMATED_TESTING}
+ or
+ @initial_INC < 11
+ or
+ $seen_markers->{"\$INC[$_]"}
+ or
+ ! -e $shortname
+ or
+ ! File::Spec->file_name_is_absolute($shortname)
+ ) {
+ $in_inc_skip = 0;
+ $final_out .= sprintf ( "% 3s: %s\n",
+ $_,
+ $shortname
+ );
+ }
+ elsif(! $in_inc_skip++) {
+ $final_out .= " ...\n";
+ }
+}
+
+$final_out .= "\n";
+
+if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
+
+ $final_out .= join "\n", 'Sourcing markers:', (map
+ {
+ sprintf "%*s: %s",
+ $max_marker_len => $_->{marker},
+ ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
+ }
+ sort
+ {
+ !!$b->{config_key} cmp !!$a->{config_key}
+ or
+ ( $a->{marker}||'') cmp ($b->{marker}||'')
+ }
+ @{$known_paths}{@seen_known_paths}
+ ), '', '';
+
+}
+
+$final_out .= "=============================\n";
+
+$final_out .= join "\n", (map
+ { sprintf (
+ "%*s %*s %*s%s",
+ $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
+ $max_ver_len => ( defined $interesting_modules->{$_}{version}
+ ? $interesting_modules->{$_}{version}
+ : ''
+ ),
+ -78 => $_,
+ ($interesting_modules->{$_}{abs_unix_path}
+ ? " [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
+ : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
+ ),
+ ) }
+ sort { lc($a) cmp lc($b) } keys %$interesting_modules
+), '';
+
+$final_out .= "=============================\n$discl\n\n";
+
+diag $final_out;
+
+exit 0;
+
+
+
+sub say_err { print STDERR "\n", @_, "\n\n" };
+
+# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
+sub try_module_require {
+ # trap deprecation warnings and whatnot
+ local $SIG{__WARN__} = sub {};
+ local $@;
+ eval "require $_[0]";
+}
+
+sub abs_unix_path {
+ return '' unless (
+ defined $_[0]
+ and
+ ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
+ );
+
+ # File::Spec's rel2abs does not resolve symlinks
+ # we *need* to look at the filesystem to be sure
+ my $abs_fn = abs_path($_[0]);
+
+ if ( $^O eq 'MSWin32' and $abs_fn ) {
+
+ # sometimes we can get a short/longname mix, normalize everything to longnames
+ $abs_fn = Win32::GetLongPathName($abs_fn);
+
+ # Fixup (native) slashes in Config not matching (unixy) slashes in INC
+ $abs_fn =~ s|\\|/|g;
+ }
+
+ $abs_fn;
+}
+
+sub shorten_fn {
+ my $fn = shift;
+
+ my $abs_fn = abs_unix_path($fn);
+
+ if (my $p = subpath_of_known_path( $fn ) ) {
+ $abs_fn =~ s| (?<! / ) $|/|x
+ if -d $abs_fn;
+
+ if ($p->{rel_path}) {
+ $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
+ and return $abs_fn;
+ }
+ elsif ($p->{config_key}) {
+ $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
+ and
+ $seen_markers->{$p->{marker}} = 1
+ and
+ return $abs_fn;
+ }
+ }
+
+ # we got so far - not a known path
+ # return the unixified version it if was absolute, leave as-is otherwise
+ my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) )
+ ? $abs_fn
+ : $fn
+ ;
+
+ $rv = "( ! -e ) $rv" unless -e $rv;
+
+ return $rv;
+}
+
+sub subpath_of_known_path {
+ my $abs_fn = abs_unix_path( $_[0] )
+ or return '';
+
+ for my $p (
+ sort {
+ length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
+ or
+ ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
+ }
+ values %$known_paths
+ ) {
+ # run through the matcher twice - first always append a /
+ # then try without
+ # important to avoid false positives
+ for my $suff ( '/', '' ) {
+ return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
+ }
+ }
+}
+
+sub module_found_at_inc_index {
+ my ($mod, $inc_dirs) = @_;
+
+ return undef unless @$inc_dirs;
+
+ my $fn = module_notional_filename($mod);
+
+ for my $i ( 0 .. $#$inc_dirs ) {
+
+ # searching from here on out won't mean anything
+ # FIXME - there is actually a way to interrogate this safely, but
+ # that's a fight for another day
+ return undef if length ref $inc_dirs->[$i];
+
+ if (
+ -d $inc_dirs->[$i]
+ and
+ -f "$inc_dirs->[$i]/$fn"
+ and
+ -r "$inc_dirs->[$i]/$fn"
+ ) {
+ return $i;
+ }
+ }
+
+ return undef;
+}
+
+sub purge_identically_versioned_submodules_with_markers {
+ my $markers = shift;
+
+ return unless @$markers;
+
+ for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
+
+ next unless defined $interesting_modules->{$mod}{version};
+
+ my $marker = $interesting_modules->{$mod}{source_marker}
+ or next;
+
+ next unless grep { $marker eq $_ } @$markers;
+
+ my $parent = $mod;
+
+ while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
+ $interesting_modules->{$parent}
+ and
+ ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
+ and
+ ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
+ and
+ delete $interesting_modules->{$mod}
+ and
+ last
+ }
+ }
+}
+
+sub module_notional_filename {
+ (my $fn = $_[0] . '.pm') =~ s|::|/|g;
+ $fn;
+}
+
+sub get_md5 {
+ # we already checked for -r/-f, just bail if can't open
+ open my $fh, '<:raw', $_[0] or return '';
+ Digest::MD5->new->addfile($fh)->hexdigest;
+}
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use DBIx::Class::_Util 'sigwarn_silencer';
-use Path::Class::File ();
+use DBIx::Class::_Util qw(sigwarn_silencer serialize);
use Math::BigInt;
use List::Util qw/shuffle/;
-use Storable qw/nfreeze dclone/;
+
+{
+ package DBICTest::StringifiesOnly;
+ use overload
+ '""' => sub { $_[0]->[0] },
+ fallback => 0,
+ ;
+}
+{
+ package DBICTest::StringifiesViaFallback;
+ use overload
+ 'bool' => sub { $_[0]->[0] },
+ ;
+}
my $schema = DBICTest->init_schema();
is($link4->url, undef, 'Link 4 url');
is($link4->title, 'dtitle', 'Link 4 title');
+## variable size dataset
+@links = $schema->populate('Link', [
+[ qw/id title url/ ],
+[ 41 ],
+[ 42, undef, 'url42' ],
+]);
+is(scalar @links, 2);
+is($links[0]->url, undef);
+is($links[1]->url, 'url42');
-## make sure populate -> insert_bulk honors fields/orders in void context
+## make sure populate -> _insert_bulk honors fields/orders in void context
## schema order
$schema->populate('Link', [
[ qw/id url title/ ],
is($link7->url, undef, 'Link 7 url');
is($link7->title, 'gtitle', 'Link 7 title');
+## variable size dataset in void ctx
+$schema->populate('Link', [
+[ qw/id title url/ ],
+[ 71 ],
+[ 72, undef, 'url72' ],
+]);
+@links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
+is(scalar @links, 2);
+is($links[0]->url, undef);
+is($links[1]->url, 'url72');
+
+## variable size dataset in void ctx, hash version
+$schema->populate('Link', [
+ { id => 73 },
+ { id => 74, title => 't74' },
+ { id => 75, url => 'u75' },
+]);
+@links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
+is(scalar @links, 3);
+is($links[0]->url, undef);
+is($links[0]->title, undef);
+is($links[1]->url, undef);
+is($links[1]->title, 't74');
+is($links[2]->url, 'u75');
+is($links[2]->title, undef);
+
+## Make sure the void ctx trace is sane
+{
+ for (
+ [
+ [ qw/id title url/ ],
+ [ 81 ],
+ [ 82, 't82' ],
+ [ 83, undef, 'url83' ],
+ ],
+ [
+ { id => 91 },
+ { id => 92, title => 't92' },
+ { id => 93, url => 'url93' },
+ ]
+ ) {
+ $schema->is_executed_sql_bind(
+ sub {
+ $schema->populate('Link', $_);
+ },
+ [
+ [ 'BEGIN' ],
+ [
+ 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
+ "__BULK_INSERT__"
+ ],
+ [ 'COMMIT' ],
+ ]
+ );
+ }
+}
+
# populate with literals
{
my $rs = $schema->resultset('Link');
$rs->delete;
- # test insert_bulk with all literal sql (no binds)
+ # test populate with all literal sql (no binds)
$rs->populate([
(+{
my $rs = $schema->resultset('Link');
$rs->delete;
- # test insert_bulk with all literal/bind sql
+ # test populate with all literal/bind sql
$rs->populate([
(+{
url => \['?', [ {} => 'cpan.org' ] ],
$rs->delete;
- # test insert_bulk with mix literal and literal/bind
+ # test populate with mix literal and literal/bind
$rs->populate([
(+{
url => \"'cpan.org'",
# test mixed binds with literal sql/bind
$rs->populate([ map { +{
- url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ],
+ url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
title => "The 'best of' cpan",
} } (1 .. 5) ]);
} 'literal+bind with semantically identical attrs works after normalization';
# test all kinds of population with stringified objects
+# or with empty sets
warnings_like {
- local $ENV{DBIC_RT79576_NOWARN};
-
my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
# the stringification has nothing to do with the artist name
# this is solely for testing consistency
- my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
- my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
+ my $fn = bless [ 'somedir/somefilename.tmp' ], 'DBICTest::StringifiesOnly';
+ my $fn2 = bless [ 'somedir/someotherfilename.tmp' ], 'DBICTest::StringifiesViaFallback';
my $rank = Math::BigInt->new(42);
my $args = {
- 'stringifying objects after regular values' => [ map
- { { name => $_, rank => $rank } }
- (
+ 'stringifying objects after regular values' => { AoA => [
+ [qw( name rank )],
+ ( map { [ $_, $rank ] } (
'supplied before stringifying objects',
'supplied before stringifying objects 2',
$fn,
$fn2,
- )
- ],
- 'stringifying objects before regular values' => [ map
- { { name => $_, rank => $rank } }
- (
+ )),
+ ]},
+
+ 'stringifying objects before regular values' => { AoA => [
+ [qw( rank name )],
+ ( map { [ $rank, $_ ] } (
$fn,
$fn2,
'supplied after stringifying objects',
'supplied after stringifying objects 2',
- )
- ],
- 'stringifying objects between regular values' => [ map
- { { name => $_, rank => $rank } }
- (
+ )),
+ ]},
+
+ 'stringifying objects between regular values' => { AoA => [
+ [qw( name rank )],
+ ( map { [ $_, $rank ] } (
'supplied before stringifying objects',
$fn,
$fn2,
'supplied after stringifying objects',
- )
- ],
- 'stringifying objects around regular values' => [ map
- { { name => $_, rank => $rank } }
- (
+ ))
+ ]},
+
+ 'stringifying objects around regular values' => { AoA => [
+ [qw( rank name )],
+ ( map { [ $rank, $_ ] } (
$fn,
'supplied between stringifying objects',
$fn2,
- )
- ],
+ ))
+ ]},
+
+ 'single stringifying object' => { AoA => [
+ [qw( rank name )],
+ [ $rank, $fn ],
+ ]},
+
+ 'empty set' => { AoA => [
+ [qw( name rank )],
+ ]},
};
- local $Storable::canonical = 1;
- my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
+ # generate the AoH equivalent based on the AoAs above
+ # also generate the expected HRI output ( is_deeply is too smart for its own good )
+ for my $bag (values %$args) {
+ $bag->{AoH} = [];
+ $bag->{Expected} = [];
+ my @hdr = @{$bag->{AoA}[0]};
+ for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
+ push @{$bag->{AoH}}, my $h = {};
+ @{$h}{@hdr} = @$v;
+
+ push @{$bag->{Expected}}, my $hs = {};
+ @{$hs}{@hdr} = map { "$_" } @$v;
+ }
+ }
- for my $tst (keys %$args) {
+ local $Storable::canonical = 1;
+ my $preimage = serialize($args);
- # test void ctx
- $rs->delete;
- $rs->populate($args->{$tst});
- is_deeply(
- $rs->all_hri,
- $args->{$tst},
- "Populate() $tst in void context"
- );
- # test non-void ctx
- $rs->delete;
- my $dummy = $rs->populate($args->{$tst});
- is_deeply(
- $rs->all_hri,
- $args->{$tst},
- "Populate() $tst in non-void context"
- );
+ for my $tst (keys %$args) {
+ for my $type (qw(AoA AoH)) {
+
+ # test void ctx
+ $rs->delete;
+ $rs->populate($args->{$tst}{$type});
+ is_deeply(
+ $rs->all_hri,
+ $args->{$tst}{Expected},
+ "Populate() $tst in void context"
+ );
+
+ # test scalar ctx
+ $rs->delete;
+ my $dummy = $rs->populate($args->{$tst}{$type});
+ is_deeply(
+ $rs->all_hri,
+ $args->{$tst}{Expected},
+ "Populate() $tst in non-void context"
+ );
+
+ # test list ctx
+ $rs->delete;
+ my @dummy = $rs->populate($args->{$tst}{$type});
+ is_deeply(
+ $rs->all_hri,
+ $args->{$tst}{Expected},
+ "Populate() $tst in non-void context"
+ );
+ }
# test create() as we have everything set up already
$rs->delete;
- $rs->create($_) for @{$args->{$tst}};
+ $rs->create($_) for @{$args->{$tst}{AoH}};
is_deeply(
$rs->all_hri,
- $args->{$tst},
+ $args->{$tst}{Expected},
"Create() $tst"
);
}
ok (
- ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
+ ($preimage eq serialize($args)),
'Arguments fed to populate()/create() unchanged'
);
$rs->delete;
-} [
- # warning to be removed around Apr 1st 2015
- # smokers start failing a month before that
- (
- ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
- or
- ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
- )
- ? ()
- # one unique for populate() and create() each
- : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2
-], 'Data integrity warnings as planned';
+} [], 'Data integrity warnings gone as planned';
-lives_ok {
+$schema->is_executed_sql_bind(
+ sub {
$schema->resultset('TwoKeys')->populate([{
artist => 1,
cd => 5,
autopilot => 'b',
}]
}])
-} 'multicol-PK has_many populate works';
+ },
+ [
+ [ 'BEGIN' ],
+ [ 'INSERT INTO twokeys ( artist, cd)
+ VALUES ( ?, ? )',
+ '__BULK_INSERT__'
+ ],
+ [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
+ VALUES (
+ ?, ?, ?, ?, ?,
+ ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
+ ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
+ )
+ ',
+ '__BULK_INSERT__'
+ ],
+ [ 'COMMIT' ],
+ ],
+ 'multicol-PK has_many populate expected trace'
+);
lives_ok ( sub {
$schema->populate('CD', [
use warnings;
use Test::More;
+use Test::Warn;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $art_rs = $schema->resultset('Artist');
my $cd_rs = $schema->resultset('CD');
-my $restricted_art_rs = $art_rs->search({rank => 42});
+my $restricted_art_rs = $art_rs->search({ -and => [ rank => 42, charfield => { '=', \['(SELECT MAX(artistid) FROM artist) + ?', 6] } ] });
ok( $schema, 'Got a Schema object');
ok( $art_rs, 'Got Good Artist Resultset');
SCHEMA_POPULATE1: {
- ## Test to make sure that the old $schema->populate is using the new method
- ## for $resultset->populate when in void context and with sub objects.
+ # throw a monkey wrench
+ my $post_jnap_monkeywrench = $schema->resultset('Artist')->find(1)->update({ name => undef });
- $schema->populate('Artist', [
+ warnings_exist { $schema->populate('Artist', [
[qw/name cds/],
["001First Artist", [
[undef, [
{title=>"004Title1", year=>2010}
]],
- ]);
+ ]) } qr/\QFast-path populate() of non-uniquely identifiable rows with related data is not possible/;
isa_ok $schema, 'DBIx::Class::Schema';
- my ($undef, $artist1, $artist2, $artist3 ) = $schema->resultset('Artist')->search({
+ my ( $preexisting_undef, $artist1, $artist2, $artist3, $undef ) = $schema->resultset('Artist')->search({
name=>["001First Artist","002Second Artist","003Third Artist", undef]},
- {order_by=>'name ASC'})->all;
+ {order_by => { -asc => 'artistid' }})->all;
isa_ok $artist1, 'DBICTest::Artist';
isa_ok $artist2, 'DBICTest::Artist';
ok $artist3->cds->count eq 1, "Got Right number of CDs for Artist3";
ok $undef->cds->count eq 1, "Got Right number of CDs for Artist4";
+ $post_jnap_monkeywrench->delete;
+
ARTIST1CDS: {
my ($cd1, $cd2, $cd3) = $artist1->cds->search(undef, {order_by=>'year ASC'});
]);
## Did it use the condition in the resultset?
+ $more_crap->discard_changes;
cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
+ cmp_ok( $more_crap->charfield, '==', $more_crap->id + 5, "Got Correct charfield for result object");
}
}
},
];
- $cd_rs->populate($cds);
+ warnings_exist {
+ $cd_rs->populate($cds)
+ } qr/\QFast-path populate() of belongs_to relationship data is not possible/;
my ($cdA, $cdB) = $cd_rs->search(
{title=>[sort map {$_->{title}} @$cds]},
},
];
- $cd_rs->populate($cds);
+ warnings_exist {
+ $cd_rs->populate($cds);
+ } qr/\QFast-path populate() of belongs_to relationship data is not possible/;
my ($cdA, $cdB, $cdC) = $cd_rs->search(
{title=>[sort map {$_->{title}} @$cds]},
})->first;
## Did it use the condition in the resultset?
+ $more_crap->discard_changes;
cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
+ cmp_ok( $more_crap->charfield, '==', $more_crap->id + 5, "Got Correct charfield for result object");
}
}
is $cooler->name, 'Cooler', 'Correct Name';
is $lamer->name, 'Lamer', 'Correct Name';
- cmp_ok $cooler->rank, '==', 42, 'Correct Rank';
+ for ($cooler, $lamer) {
+ $_->discard_changes;
+ cmp_ok( $_->rank, '==', 42, "Got Correct rank for result object");
+ cmp_ok( $_->charfield, '==', $_->id + 5, "Got Correct charfield for result object");
+ }
ARRAY_CONTEXT_WITH_COND_FROM_RS: {
]);
## Did it use the condition in the resultset?
+ $mega_lamer->discard_changes;
cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object");
+ cmp_ok( $mega_lamer->charfield, '==', $mega_lamer->id + 5, "Got Correct charfield for result object");
}
VOID_CONTEXT_WITH_COND_FROM_RS: {
## Did it use the condition in the resultset?
cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object");
+ cmp_ok( $mega_lamer->charfield, '==', $mega_lamer->id + 5, "Got Correct charfield for result object");
}
}
-ok(eval { $art_rs->populate([]); 1 }, "Empty populate runs but does nothing");
+EMPTY_POPULATE: {
+ foreach(
+ [ empty => [] ],
+ [ columns_only => [ [qw(name rank charfield)] ] ],
+ ) {
+ my ($desc, $arg) = @{$_};
+
+ $schema->is_executed_sql_bind( sub {
+
+ my $rs = $art_rs;
+ lives_ok { $rs->populate($arg); 1 } "$desc populate in void context lives";
+
+ my @r = $art_rs->populate($arg);
+ is_deeply( \@r, [], "$desc populate in list context returns empty list" );
+
+ my $r = $art_rs->populate($arg);
+ is( $r, undef, "$desc populate in scalar context returns undef" );
+
+ }, [], "$desc populate executed no statements" );
+ }
+}
done_testing;
{
result_class => 'DBIx::Class::ResultClass::HashRefInflator',
prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
+ order_by => 'tracks.trackid',
},
)->all
],
result_class => 'DBIx::Class::ResultClass::HashRefInflator',
prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
columns => [qw/cdid single_track title/], # to match the columns retrieved by the virtview
+ order_by => 'tracks.trackid',
},
)->all
],
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
$schema->storage->sql_maker->quote_char('"');
my $last_obj = $rs->search ({}, { order_by => { -desc => 'artistid' }, rows => 1})->single;
my $last_id = $last_obj ? $last_obj->artistid : 0;
-
-my ($sql, @bind);
-my $orig_debugobj = $schema->storage->debugobj;
-my $orig_debug = $schema->storage->debug;
-
-$schema->storage->debugobj (DBIC::DebugObj->new (\$sql, \@bind) );
-$schema->storage->debug (1);
-
my $obj;
-lives_ok { $obj = $rs->create ({}) } 'Default insert successful';
-
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
- 'INSERT INTO "artist" DEFAULT VALUES',
- [],
- 'Default-value insert correct SQL',
-);
+$schema->is_executed_sql_bind( sub {
+ $obj = $rs->create ({})
+}, [[
+ 'INSERT INTO "artist" DEFAULT VALUES'
+]], 'Default-value insert correct SQL' );
ok ($obj, 'Insert defaults ( $rs->create ({}) )' );
use Test::More;
use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
'Exception-arrayref contents preserved',
);
+for my $ap (qw(
+ DBICTest::AntiPattern::TrueZeroLen
+ DBICTest::AntiPattern::NullObject
+)) {
+ eval "require $ap";
+
+ warnings_like {
+ eval {
+ $schema->txn_do (sub { die $ap->new });
+ };
+
+ isa_ok $@, $ap;
+ } qr/\QObjects of external exception class '$ap' stringify to '' (the empty string)/,
+ 'Proper warning on encountered antipattern';
+
+ warnings_are {
+ $@ = $ap->new;
+ $schema->txn_do (sub { 1 });
+
+ $@ = $ap->new;
+ $schema->txn_scope_guard->commit;
+ } [], 'No spurious PSA warnings on pre-existing antipatterns in $@';
+
+}
+
done_testing;
isa_ok( $@, 'DBIx::Class::Exception' );
# Now lets rethrow via exception_action
-$schema->exception_action(sub { die @_ });
-throws_ok \&$throw, $ex_regex;
+{
+ my $handler_execution_counter = 0;
+
+ $schema->exception_action(sub {
+ $handler_execution_counter++;
+ like $_[0], $ex_regex, "Exception is precisely passed to exception_action";
+ die @_
+ });
+
+ throws_ok \&$throw, $ex_regex;
+ is $handler_execution_counter, 1, "exception_action handler executed exactly once";
+}
#
# This should have never worked!!!
throws_ok { $schema->storage->throw_exception('floob') }
qr/DBICTest::Exception is handling this: floob/;
+# test antipatterns
+for my $ap (qw(
+ DBICTest::AntiPattern::TrueZeroLen
+ DBICTest::AntiPattern::NullObject
+)) {
+ eval "require $ap";
+ my $exp_warn = qr/\QObjects of external exception class '$ap' stringify to '' (the empty string)/;
+
+ # make sure an exception_action can replace $@ with an antipattern
+ $schema->exception_action(sub { die $ap->new });
+ warnings_like {
+ eval { $throw->() };
+ isa_ok $@, $ap;
+ } $exp_warn, 'proper warning on antipattern encountered within exception_action';
+
+ # and make sure that the rethrow works
+ $schema->exception_action(sub { die @_ });
+ warnings_like {
+ eval {
+ $schema->txn_do (sub { die $ap->new });
+ };
+
+ isa_ok $@, $ap;
+ } $exp_warn, 'Proper warning on encountered antipattern';
+}
+
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use lib 't/lib';
+use DBICTest::RunMode;
+BEGIN {
+ if( DBICTest::RunMode->is_plain ) {
+ print "1..0 # SKIP not running dangerous segfault-prone test on plain install\n";
+ exit 0;
+ }
+}
+
+use File::Temp ();
+use DBIx::Class::_Util 'scope_guard';
+use DBIx::Class::Schema;
+
+# Do not use T::B - the test is hard enough not to segfault as it is
+my $test_count = 0;
+
+# start with one failure, and decrement it at the end
+my $failed = 1;
+
+sub ok {
+ printf STDOUT ("%s %u - %s\n",
+ ( $_[0] ? 'ok' : 'not ok' ),
+ ++$test_count,
+ $_[1] || '',
+ );
+
+ unless( $_[0] ) {
+ $failed++;
+ printf STDERR ("# Failed test #%d at %s line %d\n",
+ $test_count,
+ (caller(0))[1,2]
+ );
+ }
+
+ return !!$_[0];
+}
+
+# yes, make it even dirtier
+my $schema = 'DBIx::Class::Schema';
+
+$schema->connection('dbi:SQLite::memory:');
+
+# this is incredibly horrible...
+# demonstrate utter breakage of the reconnection/retry logic
+#
+open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!";
+my $tf = File::Temp->new( UNLINK => 1 );
+
+my $output;
+
+ESCAPE:
+{
+ my $guard = scope_guard {
+ close STDERR;
+ open(STDERR, '>&', $stderr_copy);
+ $output = do { local (@ARGV, $/) = $tf; <> };
+ close $tf;
+ unlink $tf;
+ undef $tf;
+ close $stderr_copy;
+ };
+
+ close STDERR;
+ open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!";
+
+ $schema->storage->ensure_connected;
+ $schema->storage->_dbh->disconnect;
+
+ local $SIG{__WARN__} = sub {};
+
+ $schema->exception_action(sub {
+ ok(1, 'exception_action invoked');
+ # essentially what Dancer2's redirect() does after https://github.com/PerlDancer/Dancer2/pull/485
+ # which "nicely" combines with: https://metacpan.org/source/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pm#L143
+ # as encouraged by: https://metacpan.org/pod/release/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pod#Logging-DBIC-database-queries-and-errors
+ last ESCAPE;
+ });
+
+ # this *DOES* throw, but the exception will *NEVER SHOW UP*
+ $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref("SELECT * FROM wfwqfdqefqef") } );
+
+ # NEITHER will this
+ ok(0, "Nope");
+}
+
+ok(1, "Post-escape reached");
+
+ok(
+ !!( $output =~ /DBIx::Class INTERNAL PANIC.+FIX YOUR ERROR HANDLING/s ),
+ 'Proper warning emitted on STDERR'
+) or print STDERR "Instead found:\n\n$output\n";
+
+print "1..$test_count\n";
+
+# this is our "done_testing"
+$failed--;
+
+# avoid tasty segfaults on 5.8.x
+exit( $failed );
cmp_ok(DBICTest->resultset('Artist')->count, '>', 0, 'count is valid');
-# cleanup globals so we do not trigger the leaktest
-for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
- $_->class_resolver(undef);
- $_->resultset_instance(undef);
- $_->result_source_instance(undef);
-}
-{
- no warnings qw/redefine once/;
- *DBICTest::schema = sub {};
-}
-
done_testing;
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 19;
-
# select from a class with resultset_attributes
my $resultset = $schema->resultset('BooksInLibrary');
is($resultset, 3, "select from a class with resultset_attributes okay");
+$resultset = $resultset->search({}, { where => undef });
+is($resultset, 3, "where condition not obliterated");
+
# now test out selects through a resultset
my $owner = $schema->resultset('Owners')->find({name => "Newton"});
my $programming_perl = $owner->books->find_or_create({ title => "Programming Perl" });
ok( !$@, 'many_to_many set_$rel(\@objects) did not throw');
is($pointy_objects->count, $pointy_count, 'many_to_many set_$rel($hash) count correct');
is($round_objects->count, $round_count, 'many_to_many set_$rel($hash) other rel count correct');
+
+done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
+
use strict;
use warnings;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DBIx::Class::Optional::Dependencies ();
my $main_pid = $$;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-
# README: If you set the env var to a number greater than 10,
# we will use that many children
my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1;
$num_children = 10;
}
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 });
my $parent_rs;
use strict;
use warnings;
use Test::More;
+use DBIx::Class::_Util 'sigwarn_silencer';
use lib qw(t/lib);
use DBICTest;
plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
- if $] < '5.008005';
+ if "$]" < 5.008005;
plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending'
- if $^O eq 'MSWin32' && $] < 5.014 && DBICTest::RunMode->is_plain;
+ if $^O eq 'MSWin32' && "$]" < 5.014 && DBICTest::RunMode->is_plain;
# README: If you set the env var to a number greater than 10,
# we will use that many children
isa_ok ($schema, 'DBICTest::Schema');
my @threads;
-push @threads, threads->create(sub {
- my $rsrc = $schema->source('Artist');
- undef $schema;
- isa_ok ($rsrc->schema, 'DBICTest::Schema');
- my $s2 = $rsrc->schema->clone;
-
- sleep 1; # without this many tasty crashes
-}) for (1.. $num_children);
+SKIP: {
+
+ local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i );
+
+ for (1.. $num_children) {
+ push @threads, threads->create(sub {
+ my $rsrc = $schema->source('Artist');
+ undef $schema;
+ isa_ok ($rsrc->schema, 'DBICTest::Schema');
+ my $s2 = $rsrc->schema->clone;
+
+ sleep 1; # without this many tasty crashes
+ }) || do {
+ skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1
+ if $! == Errno::EAGAIN();
+
+ die "Unable to start thread: $!";
+ };
+ }
+}
+
ok(1, "past spawning");
$_->join for @threads;
}
use threads;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
+
use strict;
use warnings;
use Test::Exception;
plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
- if $] < '5.008005';
+ if "$]" < 5.008005;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-
# README: If you set the env var to a number greater than 10,
# we will use that many children
my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
$num_children = 10;
}
-use_ok('DBICTest::Schema');
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
}
use threads;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
+
use strict;
use warnings;
use Test::More;
plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
- if $] < '5.008005';
+ if "$]" < 5.008005;
-use DBIx::Class::Optional::Dependencies ();
use Scalar::Util 'weaken';
use lib qw(t/lib);
use DBICTest;
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
-
my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-use_ok('DBICTest::Schema');
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
use warnings;
use Test::More;
+use lib qw(t/lib);
+use DBICTest::RunMode;
+use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
+use Scalar::Util qw(weaken blessed reftype);
+use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt);
+BEGIN {
+ plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
+ if DBIx::Class::_ENV_::PEEPEENESS;
+}
+
+
my $TB = Test::More->builder;
if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
- # without this explicit close older TBs warn in END after a ->reset
- if ($TB->VERSION < 1.005) {
- close ($TB->$_) for (qw/output failure_output todo_output/);
- }
+ # without this explicit close TB warns in END after a ->reset
+ close ($TB->$_) for qw(output failure_output todo_output);
- # if I do not do this, I get happy sigpipes on new TB, no idea why
- # (the above close-and-forget doesn't work - new TB does *not* reopen
- # its handles automatically anymore)
- else {
- for (qw/failure_output todo_output/) {
- close $TB->$_;
- open ($TB->$_, '>&', *STDERR);
- }
-
- close $TB->output;
+ # newer TB does not auto-reopen handles
+ if ( modver_gt_or_eq( 'Test::More', '1.200' ) ) {
+ open ($TB->$_, '>&', *STDERR)
+ for qw( failure_output todo_output );
open ($TB->output, '>&', *STDOUT);
}
$TB->reset;
}
-use lib qw(t/lib);
-use DBICTest::RunMode;
-use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
-use Scalar::Util qw(weaken blessed reftype);
-use DBIx::Class;
-use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer);
-BEGIN {
- plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
- if DBIx::Class::_ENV_::PEEPEENESS;
-}
-
# this is what holds all weakened refs to be checked for leakage
my $weak_registry = {};
my $has_dt;
# Skip the heavy-duty leak tracing when just doing an install
-unless (DBICTest::RunMode->is_plain) {
+# or when having Moose crap all over everything
+if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) {
# redefine the bless override so that we can catch each and every object created
no warnings qw/redefine once/;
# Test Builder is now making a new object for every pass/fail (que bloat?)
# and as such we can't really store any of its objects (since it will
# re-populate the registry while checking it, ewwww!)
- return $obj if (ref $obj) =~ /^TB2::/;
+ return $obj if (ref $obj) =~ /^TB2::|^Test::Stream/;
# populate immediately to avoid weird side effects
return populate_weakregistry ($weak_registry, $obj );
# Load them and empty the registry
# this loads the DT armada
- $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite');
+ $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for([qw( test_rdbms_sqlite ic_dt )]);
require Errno;
require DBI;
my $rs = $schema->resultset ('Artist');
my $storage = $schema->storage;
- ok ($storage->connected, 'we are connected');
-
my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work
ok ($row_obj, 'row from db');
! DBICTest::RunMode->is_plain
and
! $ENV{DBICTEST_IN_PERSISTENT_ENV}
- and
- # FIXME - investigate wtf is going on with 5.18
- ! ( $] > 5.017 and $ENV{DBIC_TRACE_PROFILE} )
) {
# FIXME - ideally we should be able to just populate an alternative
delete $weak_registry->{$addr}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
}
+ elsif ($names =~ /^B::Hooks::EndOfScope::PP::_TieHintHashFieldHash/m) {
+ # there is one tied lexical which stays alive until GC time
+ # https://metacpan.org/source/ETHER/B-Hooks-EndOfScope-0.15/lib/B/Hooks/EndOfScope/PP/FieldHash.pm#L24
+ # simply ignore it here, instead of teaching the leaktracer to examine ties
+ # the latter is possible yet terrible: https://github.com/dbsrgits/dbix-class/blob/v0.082820/t/lib/DBICTest/Util/LeakTracer.pm#L113-L117
+ delete $weak_registry->{$addr}
+ unless $cleared->{bheos_pptiehinthashfieldhash}++;
+ }
+ elsif ($names =~ /^DateTime::TimeZone::UTC/m) {
+ # DT is going through a refactor it seems - let it leak zones for now
+ delete $weak_registry->{$addr};
+ }
elsif (
# # if we can look at closed over pieces - we will register it as a global
# !DBICTest::Util::LeakTracer::CV_TRACING
# this is ugly and dirty but we do not yet have a Test::Embedded or
# similar
-# set up -I
-require Config;
-$ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
-($ENV{PATH}) = $ENV{PATH} =~ /(.+)/;
-
-
-my $persistence_tests = {
- PPerl => {
- cmd => [qw/pperl --prefork=1/, __FILE__],
- },
- 'CGI::SpeedyCGI' => {
- cmd => [qw/speedy -- -t5/, __FILE__],
- },
-};
-
-# scgi is smart and will auto-reap after -t amount of seconds
-# pperl needs an actual killer :(
-$persistence_tests->{PPerl}{termcmd} = [
- $persistence_tests->{PPerl}{cmd}[0],
- '--kill',
- @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ],
-];
-
+my $persistence_tests;
SKIP: {
skip 'Test already in a persistent loop', 1
if $ENV{DBICTEST_IN_PERSISTENT_ENV};
skip 'Main test failed - skipping persistent env tests', 1
unless $TB->is_passing;
+ skip "Test::Builder\@@{[ Test::Builder->VERSION ]} known to break persistence tests", 1
+ if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' );
+
local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1;
- require IPC::Open2;
+ $persistence_tests = {
+ PPerl => {
+ cmd => [qw/pperl --prefork=1/, __FILE__],
+ },
+ 'CGI::SpeedyCGI' => {
+ cmd => [qw/speedy -- -t5/, __FILE__],
+ },
+ };
+
+ # scgi is smart and will auto-reap after -t amount of seconds
+ # pperl needs an actual killer :(
+ $persistence_tests->{PPerl}{termcmd} = [
+ $persistence_tests->{PPerl}{cmd}[0],
+ '--kill',
+ @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ],
+ ];
+
+ # set up -I
+ require Config;
+ $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+
+ # adjust PATH for -T
+ if (length $ENV{PATH}) {
+ ( $ENV{PATH} ) = join ( $Config::Config{path_sep},
+ map { length($_) ? File::Spec->rel2abs($_) : () }
+ split /\Q$Config::Config{path_sep}/, $ENV{PATH}
+ ) =~ /\A(.+)\z/;
+ }
for my $type (keys %$persistence_tests) { SKIP: {
unless (eval "require $type") {
if system(@cmd);
}
+ require IPC::Open2;
+
for (1,2,3) {
note ("Starting run in persistent env ($type pass $_)");
IPC::Open2::open2(my $out, undef, @cmd);
# just an extra precaution in case we blew away from the SKIP - since there are no
# PID files to go by (man does pperl really suck :(
END {
- unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
- close $_ for (*STDIN, *STDOUT, *STDERR);
+ if ($persistence_tests->{PPerl}{termcmd}) {
local $?; # otherwise test will inherit $? of the system()
- system (@{$persistence_tests->{PPerl}{termcmd}})
- if $persistence_tests->{PPerl}{termcmd};
+ require IPC::Open3;
+ open my $null, ">", File::Spec->devnull;
+ waitpid(
+ IPC::Open3::open3(undef, $null, $null, @{$persistence_tests->{PPerl}{termcmd}}),
+ 0,
+ );
}
}
# doesn't work. We don't want to have the user deal with that.
BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) {
+ if ( $^O eq 'MSWin32' and $^X =~ /\x20/ ) {
+ print "1..0 # SKIP Running this test on Windows with spaces within the perl executable path (\$^X) is not possible due to https://rt.perl.org/Ticket/Display.html?id=123907\n";
+ exit 0;
+ }
+
# it is possible the test itself is initially invoked in taint mode
# and with relative paths *and* with a relative $^X and some other
# craziness... in short: just be proactive
use Test::Exception;
use Test::Warn;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
is($schema->resultset("Artist")->count, 4, 'count ok');
+# test find on an unresolvable condition
+is(
+ $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}),
+ undef
+);
+
+
# test find_or_new
{
my $existing_obj = $schema->resultset('Artist')->find_or_new({
$new->update_or_insert;
ok($new->in_storage, 'update_or_insert insert ok');
-# test in update mode
-$new->title('Insert or Update - updated');
-$new->update_or_insert;
-is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok');
-
-SKIP: {
- skip "Tests require " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite'), 13
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
-
- # test get_inflated_columns with objects
- my $event = $schema->resultset('Event')->search->first;
- my %edata = $event->get_inflated_columns;
- is($edata{'id'}, $event->id, 'got id');
- isa_ok($edata{'starts_at'}, 'DateTime', 'start_at is DateTime object');
- isa_ok($edata{'created_on'}, 'DateTime', 'create_on DateTime object');
- is($edata{'starts_at'}, $event->starts_at, 'got start date');
- is($edata{'created_on'}, $event->created_on, 'got created date');
-
-
- # get_inflated_columns w/relation and accessor alias
- isa_ok($new->updated_date, 'DateTime', 'have inflated object via accessor');
- my %tdata = $new->get_inflated_columns;
- is($tdata{'trackid'}, 100, 'got id');
- isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object');
- is($tdata{'cd'}->id, 1, 'cd object is id 1');
- is(
- $tdata{'position'},
- $schema->resultset ('Track')->search ({cd => 1})->count,
- 'Ordered assigned proper position',
- );
- is($tdata{'title'}, 'Insert or Update - updated');
- is($tdata{'last_updated_on'}, '1973-07-19T12:01:02');
- isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column');
-}
-
throws_ok (sub {
$schema->class("Track")->load_components('DoesNotExist');
}, qr!Can't locate DBIx/Class/DoesNotExist.pm!, 'exception on nonexisting component');
$schema->source("Artist")->column_info_from_storage(1);
$schema->source("Artist")->{_columns_info_loaded} = 0;
+ my @undef_default = DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
+ ? ()
+ : ( default_value => undef )
+ ;
+
is_deeply (
$schema->source('Artist')->columns_info,
{
artistid => {
data_type => "INTEGER",
- default_value => undef,
+ @undef_default,
is_nullable => 0,
size => undef
},
charfield => {
data_type => "char",
- default_value => undef,
+ @undef_default,
is_nullable => 1,
size => 10
},
name => {
data_type => "varchar",
- default_value => undef,
+ @undef_default,
is_nullable => 1,
is_numeric => 0,
size => 100
{
artistid => {
data_type => "INTEGER",
- default_value => undef,
+ @undef_default,
is_nullable => 0,
size => undef
},
throws_ok { $schema->resultset} qr/resultset\(\) expects a source name/, 'resultset with no argument throws exception';
+throws_ok { $schema->source('Artist')->result_class->new( 'bugger' ) } qr/must be a hashref/;
+
done_testing;
$cd = $schema->resultset("CD")->first;
my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid });
-$art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
-ok($art, 'Artist found by key in the resultset');
+for my $key ('', 'primary') {
+ my $art = $artist_rs->find({ name => 'some other name' }, { $key ? (key => $key) : () });
+ is($art->artistid, $cd->get_column('artist'), "Artist found through @{[ $key ? 'explicit' : 'implicit' ]} key locked in the resultset");
+}
# collapsing and non-collapsing are separate codepaths, thus the separate tests
-
+my $ea_count = 0;
+$schema->exception_action(sub {
+ $ea_count++;
+ die @_;
+});
$artist_rs = $schema->resultset("Artist");
;
}
+is( $ea_count, 1, "exception action invoked the expected amount of times (just the exception)" );
+
+$schema->exception_action(undef);
+
$artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
'rank' => {
'data_type' => 'integer',
'is_nullable' => 0,
- 'default_value' => '13',
+ DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ? () : ( 'default_value' => '13' ),
},
'charfield' => {
'data_type' => 'char',
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use Storable qw/dclone/;
my $schema = DBICTest->init_schema();
{ order_by => 'title',
rows => 3 }
);
-my $page = $it->page(2);
-is( $page->count, 2, "standard resultset paged rs count ok" );
+{
+ my $page = $it->page(2);
-is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
+ is( $page->count, 2, "standard resultset paged rs count ok" );
+ is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
+}
# test software-based limit paging
$it = $rs->search(
$pager = $it->pager;
is ($qcnt, 0, 'No queries on rs/pager creation');
-$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+# test *requires* it to be Storable
+$it = do {
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+ Storable::dclone ($it);
+};
is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2" );
$rs->create({ title => 'bah', artist => 1, year => 2011 });
$qcnt = 0;
-$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+# test *requires* it to be Storable
+$it = do {
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+ Storable::dclone ($it);
+};
is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2, even though underlying count changed" );
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mysql';
+
use strict;
use warnings;
use Test::Exception;
use Test::Warn;
+use B::Deparse;
use DBI::Const::GetInfoType;
use Scalar::Util qw/weaken/;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql');
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
-
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 });
my $dbh = $schema->storage->dbh;
});
} 'LOCK IN SHARE MODE select works';
+my ($int_type_name, @undef_default) = DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
+ ? ('integer')
+ : ( 'INT', default_value => undef )
+;
+
my $test_type_info = {
'artistid' => {
- 'data_type' => 'INT',
+ 'data_type' => $int_type_name,
'is_nullable' => 0,
'size' => 11,
- 'default_value' => undef,
+ @undef_default,
},
'name' => {
'data_type' => 'VARCHAR',
'is_nullable' => 1,
'size' => 100,
- 'default_value' => undef,
+ @undef_default,
},
'rank' => {
- 'data_type' => 'INT',
+ 'data_type' => $int_type_name,
'is_nullable' => 0,
'size' => 11,
- 'default_value' => 13,
+ DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ? () : ( 'default_value' => '13' ),
},
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
'size' => 10,
- 'default_value' => undef,
+ @undef_default,
},
};
$test_type_info->{charfield}->{data_type} = 'VARCHAR';
}
+ if (DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE) {
+ $_->{data_type} = lc $_->{data_type} for values %$test_type_info;
+ }
+
my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
}
my $cd = $rs->next;
is ($cd->artist->name, $artist->name, 'Prefetched artist');
}, 'join does not throw (mysql 3 test)';
-
- # induce a jointype override, make sure it works even if we don't have mysql3
- local $schema->storage->sql_maker->{_default_jointype} = 'inner';
- is_same_sql_bind (
- $rs->as_query,
- '(
- SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`,
- `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield`
- FROM cd `me`
- INNER JOIN `artist` `artist` ON `artist`.`artistid` = `me`.`artist`
- )',
- [],
- 'overridden default join type works',
- );
}
## Can we properly deal with the null search problem?
is ($rs->count, 10, '10 artists present');
- my $orig_debug = $schema->storage->debug;
- $schema->storage->debug(1);
- my $query_count;
- $schema->storage->debugcb(sub { $query_count++ });
-
- $query_count = 0;
- $complex_rs->delete;
-
- is ($query_count, 1, 'One delete query fired');
+ $schema->is_executed_querycount( sub {
+ $complex_rs->delete;
+ }, 1, 'One delete query fired' );
is ($rs->count, 0, '10 Artists correctly deleted');
$rs->create({
});
is ($rs->count, 1, 'Artist with cd created');
- $query_count = 0;
- $schema->resultset('CD')->search_related('artist',
- { 'artist.name' => { -like => 'baby_with_%' } }
- )->delete;
- is ($query_count, 1, 'And one more delete query fired');
- is ($rs->count, 0, 'Artist with cd deleted');
- $schema->storage->debugcb(undef);
- $schema->storage->debug($orig_debug);
+ $schema->is_executed_querycount( sub {
+ $schema->resultset('CD')->search_related('artist',
+ { 'artist.name' => { -like => 'baby_with_%' } }
+ )->delete;
+ }, 1, 'And one more delete query fired');
+ is ($rs->count, 0, 'Artist with cd deleted');
}
ZEROINSEARCH: {
]});
warnings_exist { is_deeply (
- [ $restrict_rs->get_column('y')->all ],
- [ $y_rs->all ],
+ [ sort $restrict_rs->get_column('y')->all ],
+ [ sort $y_rs->all ],
'Zero year was correctly excluded from resultset',
) } qr/
\QUse of distinct => 1 while selecting anything other than a column \E
ok ($rs->find({ name => "Hardcore Forker $pid" }), 'Expected row created');
}
+# Ensure disappearing RDBMS does not leave the storage in an inconsistent state
+# Unlike the test in storage/reconnect.t we test live RDBMS-side disconnection
+SKIP:
+for my $cref (
+ sub {
+ my $schema = shift;
+
+ my $g = $schema->txn_scope_guard;
+
+ is( $schema->storage->transaction_depth, 1, "Expected txn depth" );
+
+ $schema->storage->_dbh->do("SELECT SLEEP(2)");
+ },
+ sub {
+ my $schema = shift;
+ $schema->txn_do(sub {
+ is( $schema->storage->transaction_depth, 1, "Expected txn depth" );
+ $schema->storage->_dbh->do("SELECT SLEEP(2)")
+ } );
+ },
+ sub {
+ my $schema = shift;
+
+ my $g = $schema->txn_scope_guard;
+
+ $schema->txn_do(sub {
+ is( $schema->storage->transaction_depth, 2, "Expected txn depth" );
+ $schema->storage->_dbh->do("SELECT SLEEP(2)")
+ } );
+ },
+) {
+ # version needed for the "read_timeout" feature
+ DBIx::Class::Optional::Dependencies->skip_without( 'DBD::mysql>=4.023' );
+
+ note( "Testing with " . B::Deparse->new->coderef2text($cref) );
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ mysql_read_timeout => 1,
+ });
+
+ ok( !$schema->storage->connected, 'Not connected' );
+
+ is( $schema->storage->transaction_depth, undef, "Start with unknown txn depth" );
+
+ throws_ok {
+ $cref->($schema)
+ } qr/Rollback failed/;
+
+ ok( !$schema->storage->connected, 'Not connected as a result of failed rollback' );
+
+ is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" );
+
+ ok( $schema->resultset('Artist')->count, 'query works after the fact' );
+}
+
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
+use Test::Warn;
use Sub::Name;
+use Config;
use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_pg');
+use SQL::Abstract 'is_literal_value';
+use DBIx::Class::_Util 'is_exception';
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => <<'EOM' unless $dsn && $user;
-Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
-( NOTE: This test drops and creates tables called 'artist', 'cd',
-'timestamp_primary_key_test', 'track', 'casecheck', 'array_test' and
-'sequence_test' as well as following sequences: 'pkid1_seq', 'pkid2_seq' and
-'nonpkid_seq'. as well as following schemas: 'dbic_t_schema',
-'dbic_t_schema_2', 'dbic_t_schema_3', 'dbic_t_schema_4', and 'dbic_t_schema_5')
-EOM
-
### load any test classes that are defined further down in the file via BEGIN blocks
-
our @test_classes; #< array that will be pushed into by test classes defined in this file
DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
### pre-connect tests (keep each test separate as to make sure rebless() runs)
{
my $s = DBICTest::Schema->connect($dsn, $user, $pass);
-
- ok (!$s->storage->_dbh, 'definitely not connected');
-
- # Check that datetime_parser returns correctly before we explicitly connect.
- SKIP: {
- skip (
- "Pg parser detection test needs " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg'),
- 2
- ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg');
-
- my $store = ref $s->storage;
- is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
-
- my $parser = $s->storage->datetime_parser;
- is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
- }
-
- ok (!$s->storage->_dbh, 'still not connected');
- }
-
- {
- my $s = DBICTest::Schema->connect($dsn, $user, $pass);
# make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
ok (!$s->storage->_dbh, 'definitely not connected');
is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
run_apk_tests($schema); #< older set of auto-pk tests
run_extended_apk_tests($schema); #< new extended set of auto-pk tests
+
+######## test the pg-specific syntax from https://rt.cpan.org/Ticket/Display.html?id=99503
+ lives_ok {
+ is(
+ $schema->resultset('Artist')->search({ artistid => { -in => \ '(select 4) union (select 5)' } })->count,
+ 2,
+ 'Two expected artists found on subselect union within IN',
+ );
+ };
+
### type_info tests
my $test_type_info = {
my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
my $artistid_defval = delete $type_info->{artistid}->{default_value};
- like($artistid_defval,
- qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
- 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
- is_deeply($type_info, $test_type_info,
- 'columns_info_for - column data types');
-
+ # The curor info is too radically different from what is in the column_info
+ # call - just punt it (DBD::SQLite tests the codepath plenty enough)
+ unless (DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE) {
+ like(
+ $artistid_defval,
+ qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
+ 'columns_info_for - sequence matches Pg get_autoinc_seq expectations'
+ );
+ is_deeply($type_info, $test_type_info,
+ 'columns_info_for - column data types');
+ }
####### Array tests
lives_ok {
is_deeply (
$arr_rs->search({ arrayfield => { '=' => { -value => [3,4] }} })->first->arrayfield,
- [3,4],,
+ [3,4],
'Array value matches explicit equal'
);
} 'searching by arrayref (explicit equal sign)';
# test inferred condition for creation
for my $cond (
{ -value => [3,4] },
- \[ '= ?' => [arrayfield => [3, 4]] ],
+ \[ '= ?' => [3, 4] ],
) {
- local $TODO = 'No introspection of complex conditions :(';
+ local $TODO = 'No introspection of complex literal conditions :('
+ if is_literal_value $cond;
+
+
my $arr_rs_cond = $arr_rs->search({ arrayfield => $cond });
my $row = $arr_rs_cond->create({});
$row->discard_changes;
is_deeply ($row->arrayfield, [3,4], 'Array value made it to storage');
}
+
+ my $arr = [ 1..10 ];
+ # exercise the creation-logic even more (akin to t/100populate.t)
+ for my $insert_value (
+ $arr,
+ { -value => $arr },
+ \[ '?', $arr ],
+ ) {
+ $arr_rs->delete;
+
+ my @objs = (
+ $arr_rs->create({ arrayfield => $insert_value }),
+ $arr_rs->populate([ { arrayfield => $insert_value } ]),
+ $arr_rs->populate([ ['arrayfield'], [ $insert_value ] ]),
+ );
+
+ my $loose_obj = $arr_rs->new({ arrayfield => $insert_value });
+
+ unless (is_literal_value $insert_value) {
+ is_deeply( $_->arrayfield, $arr, 'array value preserved during set_columns' )
+ for ($loose_obj, @objs)
+ }
+
+ push @objs, $loose_obj->insert;
+
+ $_->discard_changes for @objs;
+ is_deeply( $_->arrayfield, $arr, 'array value correct after discard_changes' )
+ for (@objs);
+
+ # insert couple more in void ctx
+ $arr_rs->populate([ { arrayfield => $insert_value } ]);
+ $arr_rs->populate([ ['arrayfield'], [ $insert_value ] ]);
+
+ # should have a total of 6 now, all pristine
+ my @retrieved_objs = $arr_rs->search({
+ arrayfield => ref $insert_value eq 'ARRAY'
+ ? { -value => $insert_value }
+ : { '=' => $insert_value }
+ })->all;
+ is scalar @retrieved_objs, 6, 'Correct count of inserted rows';
+ is_deeply( $_->arrayfield, $arr, 'array value correct after storage retrieval' )
+ for (@retrieved_objs);
+ }
}
########## Case check
lives_ok { $cds->update({ year => '2010' }) } 'Update on prefetched rs';
## Test SELECT ... FOR UPDATE
-
SKIP: {
- if(eval { require Sys::SigAction }) {
- Sys::SigAction->import( 'set_sig_handler' );
- }
- else {
- skip "Sys::SigAction is not available", 6;
- }
+ skip "Your system does not support unsafe signals (d_sigaction) - unable to run deadlock test", 1
+ unless eval { $Config{d_sigaction} and require POSIX };
my ($timed_out, $artist2);
is($artist->artistid, 1, "select returns artistid = 1");
$timed_out = 0;
+
eval {
- my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
- alarm(2);
+ # can not use %SIG assignment directly - we need sigaction below
+ # localization to a block still works however
+ local $SIG{ALRM};
+
+ POSIX::sigaction( POSIX::SIGALRM() => POSIX::SigAction->new(
+ sub { die "DBICTestTimeout" },
+ ));
+
$artist2 = $schema2->resultset('Artist')->find(1);
$artist2->name('fooey');
+
+ # FIXME - this needs to go away in lieu of a non-retrying runner
+ # ( i.e. after solving RT#47005 )
+ local *DBIx::Class::Storage::DBI::_ping = sub { 1 }, DBIx::Class::_ENV_::OLD_MRO && Class::C3->reinitialize()
+ if DBIx::Class::_Util::modver_gt_or_eq( 'DBD::Pg' => '3.5.0' );
+
+ alarm(1);
$artist2->update;
- alarm(0);
};
- $timed_out = $@ =~ /DBICTestTimeout/;
+
+ alarm(0);
+
+ if (is_exception($@)) {
+ $timed_out = $@ =~ /DBICTestTimeout/
+ or die $@;
+ }
});
$t->{test_sub}->();
$schema->resultset('Track')->create({
trackid => 1, cd => 9999, position => 1, title => 'Track1'
});
- } qr/constraint/i, 'with_deferred_fk_checks is off';
+ } qr/violates foreign key constraint/i, 'with_deferred_fk_checks is off outside of TXN';
+
+ # rerun the same under with_deferred_fk_checks
+ # it is expected to fail, hence the eval
+ # but it also should not warn
+ warnings_like {
+ eval {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+ } )
+ };
+
+ like $@, qr/violates foreign key constraint/i,
+ "Still expected exception on deferred failure at commit time";
+
+ } [], 'No warnings on deferred rollback';
}
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw(test_rdbms_pg binary_data);
+
use strict;
use warnings;
use Test::More;
-use DBIx::Class::Optional::Dependencies ();
-use Try::Tiny;
+use DBIx::Class::_Util 'modver_gt_or_eq';
+
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
-
my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $dbuser);
-
my $schema = DBICTest::Schema->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
-if ($schema->storage->_server_info->{normalized_dbms_version} >= 9.0) {
- if (not try { DBD::Pg->VERSION('2.17.2') }) {
- plan skip_all =>
- 'DBD::Pg < 2.17.2 does not work with Pg >= 9.0 BYTEA columns';
- }
-}
-elsif (not try { DBD::Pg->VERSION('2.9.2') }) {
- plan skip_all =>
- 'DBD::Pg < 2.9.2 does not work with BYTEA columns';
-}
+plan skip_all => 'DBD::Pg < 2.17.2 does not work with Pg >= 9.0 BYTEA columns' if (
+ ! modver_gt_or_eq('DBD::Pg', '2.17.2')
+ and
+ $schema->storage->_server_info->{normalized_dbms_version} >= 9.0
+);
my $dbh = $schema->storage->dbh;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle';
+
use strict;
use warnings;
use Test::More;
use Sub::Name;
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
# optional:
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
- unless ($dsn && $user && $pass);
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
-
-$ENV{NLS_SORT} = "BINARY";
-$ENV{NLS_COMP} = "BINARY";
-$ENV{NLS_LANG} = "AMERICAN";
-
{
package # hide from PAUSE
DBICTest::Schema::ArtistFQN;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle';
+
use strict;
use warnings;
use Test::More;
use Sub::Name;
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
- unless ($dsn && $user && $pass);
+use DBICTest::Schema::BindType;
+BEGIN {
+ DBICTest::Schema::BindType->add_columns(
+ 'blb2' => {
+ data_type => 'blob',
+ is_nullable => 1,
+ },
+ 'clb2' => {
+ data_type => 'clob',
+ is_nullable => 1,
+ }
+ );
+}
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+use DBICTest;
$ENV{NLS_SORT} = "BINARY";
$ENV{NLS_COMP} = "BINARY";
$ENV{NLS_LANG} = "AMERICAN";
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
my $v = do {
my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
$si->{normalized_dbms_version}
. ': https://rt.cpan.org/Ticket/Display.html?id=64206'
if $q;
- # so we can disable BLOB mega-output
- my $orig_debug = $schema->storage->debug;
-
my $id;
foreach my $size (qw( small large )) {
$id++;
- local $schema->storage->{debug} = $size eq 'large'
- ? 0
- : $orig_debug
- ;
+ local $schema->storage->{debug} = 0
+ if $size eq 'large';
my $str = $binstr{$size};
lives_ok {
- $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str" } )
+ $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str", blb2 => "blb2:$str", clb2 => "clb2:$str" } )
} "inserted $size without dying";
my %kids = %{$schema->storage->_dbh->{CachedKids}};
is @objs, 1, 'One row found matching on both LOBs';
ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly');
ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly');
+ ok (try { $objs[0]->clb2 }||'' eq "clb2:$str", "clb2 inserted correctly");
+ ok (try { $objs[0]->blb2 }||'' eq "blb2:$str", "blb2 inserted correctly");
{
local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)'
{ blob => "blob:$str", clob => "clob:$str" },
{
from => \ "(SELECT * FROM ${q}bindtype_test${q} WHERE ${q}id${q} != ?) ${q}me${q}",
- bind => [ [ undef => 12345678 ] ],
+ bind => [ [ {} => 12345678 ] ],
}
)->get_column('id')->as_query);
lives_ok {
$rs->search({ id => $id, blob => "blob:$str", clob => "clob:$str" })
- ->update({ blob => 'updated blob', clob => 'updated clob' });
+ ->update({ blob => 'updated blob', clob => 'updated clob', clb2 => 'updated clb2', blb2 => 'updated blb2' });
} 'blob UPDATE with blobs in WHERE clause survived';
@objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all;
is @objs, 1, 'found updated row';
ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly');
ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly');
+ ok (try { $objs[0]->clb2 }||'' eq "updated clb2", "clb2 updated correctly");
+ ok (try { $objs[0]->blb2 }||'' eq "updated blb2", "blb2 updated correctly");
lives_ok {
$rs->search({ id => $id })
@objs = $rs->search({ blob => "re-updated blob", clob => 're-updated clob' })->all;
is @objs, 0, 'row deleted successfully';
}
-
- $schema->storage->debug ($orig_debug);
}
do_clean ($dbh);
do_clean($dbh);
- $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}blob2${q} blob NULL, ${q}clob${q} clob NULL, ${q}clob2${q} clob NULL, ${q}a_memo${q} integer NULL)");
+ $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}blb2${q} blob NULL, ${q}clob${q} clob NULL, ${q}clb2${q} clob NULL, ${q}a_memo${q} integer NULL)");
}
# clean up our mess
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle';
+
use strict;
use warnings;
use Test::Exception;
use Test::More;
-use DBIx::Class::Optional::Dependencies ();
-use lib qw(t/lib);
-use DBICTest::RunMode;
-
-$ENV{NLS_SORT} = "BINARY";
-$ENV{NLS_COMP} = "BINARY";
-$ENV{NLS_LANG} = "AMERICAN";
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
- unless ($dsn && $user && $pass);
+# I *strongly* suspect Oracle has an implicit stable output order when
+# dealing with HQs. So just punt on the entire shuffle thing.
+BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 }
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_oracle')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_oracle');
+use lib qw(t/lib);
use DBICTest::Schema::Artist;
BEGIN {
use DBICTest;
use DBICTest::Schema;
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
note "Oracle Version: " . $schema->storage->_server_info->{dbms_version};
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2';
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2');
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/};
-
-#warn "$dsn $user $pass";
-
-plan skip_all => 'Set $ENV{DBICTEST_DB2_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
-
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
my $name_sep = $schema->storage->_dbh_get_info('SQL_QUALIFIER_NAME_SEPARATOR');
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2_400';
+
use strict;
use warnings;
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2_400')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2_400');
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/};
-
-#warn "$dsn $user $pass";
-
# Probably best to pass the DBQ option in the DSN to specify a specific
# libray. Something like:
# DBICTEST_DB2_400_DSN='dbi:ODBC:dsn=MyAS400;DBQ=MYLIB'
-plan skip_all => 'Set $ENV{DBICTEST_DB2_400_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/};
plan tests => 6;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_odbc';
+
use strict;
use warnings;
use Test::Exception;
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_odbc')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_odbc');
-
use lib qw(t/lib);
use DBICTest;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
-
{
my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version};
ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') );
my $sealed_owners = $owners->as_subselect_rs;
is_deeply (
- [ map { $_->name } ($sealed_owners->all) ],
- [ map { $_->name } ($owners->all) ],
+ [ sort map { $_->name } ($sealed_owners->all) ],
+ [ sort map { $_->name } ($owners->all) ],
"$test_type: Sort preserved from within a subquery",
);
}
is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset");
is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset");
- my $queries;
- my $orig_debug = $schema->storage->debug;
- $schema->storage->debugcb(sub { $queries++; });
- $schema->storage->debug(1);
-
- is_deeply (
- [map { $_->owner->name } ($limited_rs->all) ],
- [@owner_names[2 .. 7]],
- "$test_type: Prefetch-limited rows were properly ordered"
- );
- is ($queries, 1, "$test_type: Only one query with prefetch");
-
- $schema->storage->debugcb(undef);
- $schema->storage->debug($orig_debug);
+ $schema->is_executed_querycount( sub {
+ is_deeply (
+ [map { $_->owner->name } ($limited_rs->all) ],
+ [@owner_names[2 .. 7]],
+ "$test_type: Prefetch-limited rows were properly ordered"
+ );
+ }, 1, "$test_type: Only one query with prefetch" );
is_deeply (
[map { $_->name } ($limited_rs->search_related ('owner')->all) ],
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_ase';
+
use strict;
use warnings;
no warnings 'uninitialized';
use Test::More;
use Test::Exception;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'sigwarn_silencer';
+
use lib qw(t/lib);
use DBICTest;
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
-if (not ($dsn && $user)) {
- plan skip_all => join ' ',
- 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test.',
- 'Warning: This test drops and creates the tables:',
- "'artist', 'money_test' and 'bindtype_test'",
- ;
-};
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase');
-
my @storage_types = (
'DBI::Sybase::ASE',
'DBI::Sybase::ASE::NoBindVars',
);
-eval "require DBIx::Class::Storage::$_;" for @storage_types;
my $schema;
-my $storage_idx = -1;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
sub get_schema {
DBICTest::Schema->connect($dsn, $user, $pass, {
my $ping_count = 0;
{
+ require DBIx::Class::Storage::DBI::Sybase::ASE;
my $ping = DBIx::Class::Storage::DBI::Sybase::ASE->can('_ping');
*DBIx::Class::Storage::DBI::Sybase::ASE::_ping = sub {
$ping_count++;
}
for my $storage_type (@storage_types) {
- $storage_idx++;
unless ($storage_type eq 'DBI::Sybase::ASE') { # autodetect
DBICTest::Schema->storage_type("::$storage_type");
$schema->storage->ensure_connected;
- if ($storage_idx == 0 &&
- $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars')) {
- # no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS)
- skip "Skipping entire test for $storage_type - no placeholder support", 1;
- next;
- }
+ # we are going to explicitly test this anyway, just loop through
+ next if
+ $storage_type ne 'DBI::Sybase::ASE::NoBindVars'
+ and
+ $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars')
+ ;
isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" );
name => { -like => 'bulk artist %' }
});
-# test insert_bulk using populate.
+# test _insert_bulk using populate.
SKIP: {
- skip 'insert_bulk not supported', 4
+ skip '_insert_bulk not supported', 4
unless $storage_type !~ /NoBindVars/i;
lives_ok {
+
+ local $SIG{__WARN__} = sigwarn_silencer(qr/Sybase bulk API operation failed due to character set incompatibility/)
+ unless $ENV{DBICTEST_SYBASE_SUBTEST_RERUN};
+
$schema->resultset('Artist')->populate([
{
name => 'bulk artist 1',
charfield => 'foo',
},
]);
- } 'insert_bulk via populate';
+ } '_insert_bulk via populate';
- is $bulk_rs->count, 3, 'correct number inserted via insert_bulk';
+ is $bulk_rs->count, 3, 'correct number inserted via _insert_bulk';
is ((grep $_->charfield eq 'foo', $bulk_rs->all), 3,
- 'column set correctly via insert_bulk');
+ 'column set correctly via _insert_bulk');
my %bulk_ids;
@bulk_ids{map $_->artistid, $bulk_rs->all} = ();
is ((scalar keys %bulk_ids), 3,
- 'identities generated correctly in insert_bulk');
+ 'identities generated correctly in _insert_bulk');
$bulk_rs->delete;
}
-# make sure insert_bulk works a second time on the same connection
+# make sure _insert_bulk works a second time on the same connection
SKIP: {
- skip 'insert_bulk not supported', 3
+ skip '_insert_bulk not supported', 3
unless $storage_type !~ /NoBindVars/i;
lives_ok {
charfield => 'bar',
},
]);
- } 'insert_bulk via populate called a second time';
+ } '_insert_bulk via populate called a second time';
is $bulk_rs->count, 3,
- 'correct number inserted via insert_bulk';
+ 'correct number inserted via _insert_bulk';
is ((grep $_->charfield eq 'bar', $bulk_rs->all), 3,
- 'column set correctly via insert_bulk');
+ 'column set correctly via _insert_bulk');
$bulk_rs->delete;
}
-# test invalid insert_bulk (missing required column)
+# test invalid _insert_bulk (missing required column)
#
-# There should be a rollback, reconnect and the next valid insert_bulk should
-# succeed.
throws_ok {
+ local $SIG{__WARN__} = sigwarn_silencer(qr/Sybase bulk API operation failed due to character set incompatibility/)
+ unless $ENV{DBICTEST_SYBASE_SUBTEST_RERUN};
+
$schema->resultset('Artist')->populate([
{
charfield => 'foo',
}
]);
- } qr/no value or default|does not allow null|placeholders/i,
+ }
# The second pattern is the error from fallback to regular array insert on
# incompatible charset.
# The third is for ::NoBindVars with no syb_has_blk.
- 'insert_bulk with missing required column throws error';
-
-# now test insert_bulk with IDENTITY_INSERT
+ qr/
+ \Qno value or default\E
+ |
+ \Qdoes not allow null\E
+ |
+ \QUnable to invoke fast-path insert without storage placeholder support\E
+ /xi,
+ '_insert_bulk with missing required column throws error';
+
+# now test _insert_bulk with IDENTITY_INSERT
SKIP: {
- skip 'insert_bulk not supported', 3
+ skip '_insert_bulk not supported', 3
unless $storage_type !~ /NoBindVars/i;
lives_ok {
charfield => 'foo',
},
]);
- } 'insert_bulk with IDENTITY_INSERT via populate';
+ } '_insert_bulk with IDENTITY_INSERT via populate';
is $bulk_rs->count, 3,
- 'correct number inserted via insert_bulk with IDENTITY_INSERT';
+ 'correct number inserted via _insert_bulk with IDENTITY_INSERT';
is ((grep $_->charfield eq 'foo', $bulk_rs->all), 3,
- 'column set correctly via insert_bulk with IDENTITY_INSERT');
+ 'column set correctly via _insert_bulk with IDENTITY_INSERT');
$bulk_rs->delete;
}
$rs->delete;
- # now try insert_bulk with blobs and only blobs
+ # now try _insert_bulk with blobs and only blobs
$new_str = $binstr{large} . 'bar';
lives_ok {
$rs->populate([
clob => $new_str,
},
]);
- } 'insert_bulk with blobs does not die';
+ } '_insert_bulk with blobs does not die';
is((grep $_->blob eq $binstr{large}, $rs->all), 2,
- 'IMAGE column set correctly via insert_bulk');
+ 'IMAGE column set correctly via _insert_bulk');
is((grep $_->clob eq $new_str, $rs->all), 2,
- 'TEXT column set correctly via insert_bulk');
+ 'TEXT column set correctly via _insert_bulk');
- # now try insert_bulk with blobs and a non-blob which also happens to be an
+ # now try _insert_bulk with blobs and a non-blob which also happens to be an
# identity column
SKIP: {
- skip 'no insert_bulk without placeholders', 4
+ skip 'no _insert_bulk without placeholders', 4
if $storage_type =~ /NoBindVars/i;
$rs->delete;
a_memo => 2,
},
]);
- } 'insert_bulk with blobs and explicit identity does NOT die';
+ } '_insert_bulk with blobs and explicit identity does NOT die';
is((grep $_->blob eq $binstr{large}, $rs->all), 2,
- 'IMAGE column set correctly via insert_bulk with identity');
+ 'IMAGE column set correctly via _insert_bulk with identity');
is((grep $_->clob eq $new_str, $rs->all), 2,
- 'TEXT column set correctly via insert_bulk with identity');
+ 'TEXT column set correctly via _insert_bulk with identity');
is_deeply [ map $_->id, $rs->all ], [ 1,2 ],
- 'explicit identities set correctly via insert_bulk with blobs';
+ 'explicit identities set correctly via _insert_bulk with blobs';
}
lives_and {
$rs->update({ blob => undef });
is((grep !defined($_->blob), $rs->all), 2);
} 'blob update to NULL';
+
+ lives_ok {
+ $schema->txn_do(sub {
+ my $created = $rs->create( { clob => "some text" } );
+ });
+ } 'insert blob field in transaction';
+ $ping_count-- if $@; # failure retry triggers a ping
}
# test MONEY column support (and some other misc. stuff)
is $ping_count, 0, 'no pings';
-# if tests passed and did so under a non-C lang - let's rerun the test
-if (Test::Builder->new->is_passing and $ENV{LANG} and $ENV{LANG} ne 'C') {
- my $oldlang = $ENV{LANG};
- local $ENV{LANG} = 'C';
+# if tests passed and did so under a non-C LC_ALL - let's rerun the test
+if (Test::Builder->new->is_passing and $ENV{LC_ALL} and $ENV{LC_ALL} ne 'C') {
+
+ pass ("Your LC_ALL is set to $ENV{LC_ALL} - retesting with C");
- pass ("Your lang is set to $oldlang - retesting with C");
+ local $ENV{LC_ALL} = 'C';
+ local $ENV{DBICTEST_SYBASE_SUBTEST_RERUN} = 1;
local $ENV{PATH};
my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__);
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_ado';
+
use strict;
use warnings;
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_ado')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_ado');
-
# Example DSN (from frew):
# dbi:ADO:PROVIDER=sqlncli10;SERVER=tcp:172.24.2.10;MARS Connection=True;Initial Catalog=CIS;UID=cis_web;PWD=...;DataTypeCompatibility=80;
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
-
DBICTest::Schema->load_classes(qw/VaryingMAX ArtistGUID/);
my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
my $rs = $schema->resultset('VaryingMAX');
foreach my $size (qw/small large/) {
- my $orig_debug = $schema->storage->debug;
-
- $schema->storage->debug(0) if $size eq 'large';
+ local $schema->storage->{debug} = 0 if $size eq 'large';
my $str = $binstr{$size};
my $row;
cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches';
cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches';
cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches';
-
- $schema->storage->debug($orig_debug);
}
# test regular blobs
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_informix';
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix');
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
-#warn "$dsn $user $pass";
-
-plan skip_all => 'Set $ENV{DBICTEST_INFORMIX_DSN}, _USER and _PASS to run this test'
- unless $dsn;
-
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
auto_savepoint => 1
});
use Test::More;
use Test::Exception;
-use Scope::Guard ();
use Try::Tiny;
use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
auto_savepoint => 1
});
- my $guard = Scope::Guard->new(sub{ cleanup($schema) });
+ my $guard = scope_guard { cleanup($schema) };
my $dbh = $schema->storage->dbh;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_sybase';
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Scalar::Util 'weaken';
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test'
- unless ($dsn);
-
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_sybase')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_sybase');
-
{
my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version};
ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') );
use Test::More;
use Test::Exception;
use DBIx::Class::Optional::Dependencies ();
-use Scope::Guard ();
+use DBIx::Class::_Util 'scope_guard';
+use List::Util 'shuffle';
use Try::Tiny;
use lib qw(t/lib);
use DBICTest;
my $schema;
-for my $prefix (keys %$env2optdep) { SKIP: {
+for my $prefix (shuffle keys %$env2optdep) { SKIP: {
- my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
+ skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
+ unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
- next unless $dsn;
+ my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
note "Testing with ${prefix}_DSN";
- skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
- unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
-
$schema = DBICTest::Schema->connect($dsn, $user, $pass, {
auto_savepoint => 1,
quote_names => 1,
});
my $dbh = $schema->storage->dbh;
- my $sg = Scope::Guard->new(sub { cleanup($schema) });
+ my $sg = scope_guard { cleanup($schema) };
eval { $dbh->do(q[DROP TABLE "artist"]) };
$dbh->do(<<EOF);
use Test::More;
use Test::Exception;
-use Scope::Guard ();
use Try::Tiny;
use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj ();
-use DBIC::SqlMakerTest;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
LongReadLen => $maxloblen,
});
- my $guard = Scope::Guard->new(sub { cleanup($schema) });
+ my $guard = scope_guard { cleanup($schema) };
my $dbh = $schema->storage->dbh;
title => 'my track',
});
- my ($sql, @bind);
-
my $joined_track = try {
- local $schema->storage->{debug} = 1;
- local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
-
$schema->resultset('Artist')->search({
artistid => $first_artistid,
}, {
diag "Could not execute two-step left join: $_";
};
- s/^'//, s/'\z// for @bind;
-
- # test is duplicated in t/sqlmaker/msaccess.t, keep a duplicate here anyway, just to be safe
- # -- ribasushi
- is_same_sql_bind(
- $sql,
- \@bind,
- 'SELECT [me].[artistid], [me].[name], [me].[rank], [me].[charfield], [tracks].[title] FROM ( ( [artist] [me] LEFT JOIN cd [cds] ON [cds].[artist] = [me].[artistid] ) LEFT JOIN [track] [tracks] ON [tracks].[cd] = [cds].[cdid] ) WHERE ( [artistid] = ? )',
- [1],
- 'correct SQL for two-step left join',
- );
-
is try { $joined_track->get_column('track_title') }, 'my track',
'two-step left join works';
- ($sql, @bind) = ();
-
$joined_artist = try {
- local $schema->storage->{debug} = 1;
- local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
-
$schema->resultset('Track')->search({
trackid => $track->trackid,
}, {
diag "Could not execute two-step inner join: $_";
};
- s/^'//, s/'\z// for @bind;
-
- # test is duplicated in t/sqlmaker/msaccess.t, keep a duplicate here anyway, just to be safe
- # -- ribasushi
- is_same_sql_bind(
- $sql,
- \@bind,
- 'SELECT [me].[trackid], [me].[cd], [me].[position], [me].[title], [me].[last_updated_on], [me].[last_updated_at], [artist].[name] FROM ( ( [track] [me] INNER JOIN cd [cd] ON [cd].[cdid] = [me].[cd] ) INNER JOIN [artist] [artist] ON [artist].[artistid] = [cd].[artist] ) WHERE ( [trackid] = ? )',
- [$track->trackid],
- 'correct SQL for two-step inner join',
- );
-
is try { $joined_artist->get_column('artist_name') }, 'foo',
'two-step inner join works';
use lib qw(t/lib);
use DBICTest;
-use DBIx::Class::_Util qw(sigwarn_silencer modver_gt_or_eq);
+use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt );
-# savepoints test
-{
- my $schema = DBICTest->init_schema(auto_savepoint => 1);
-
- my $ars = $schema->resultset('Artist');
-
- # test two-phase commit and inner transaction rollback from nested transactions
- $schema->txn_do(sub {
- $ars->create({ name => 'in_outer_transaction' });
- $schema->txn_do(sub {
- $ars->create({ name => 'in_inner_transaction' });
- });
- ok($ars->search({ name => 'in_inner_transaction' })->first,
- 'commit from inner transaction visible in outer transaction');
- throws_ok {
- $schema->txn_do(sub {
- $ars->create({ name => 'in_inner_transaction_rolling_back' });
- die 'rolling back inner transaction';
- });
- } qr/rolling back inner transaction/, 'inner transaction rollback executed';
- $ars->create({ name => 'in_outer_transaction2' });
- });
-
- ok($ars->search({ name => 'in_outer_transaction' })->first,
- 'commit from outer transaction');
- ok($ars->search({ name => 'in_outer_transaction2' })->first,
- 'second commit from outer transaction');
- ok($ars->search({ name => 'in_inner_transaction' })->first,
- 'commit from inner transaction');
- is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
- undef,
- 'rollback from inner transaction';
-}
+# make one deploy() round before we load anything else - need this in order
+# to prime SQLT if we are using it (deep depchain is deep)
+DBICTest->init_schema( no_populate => 1 );
# check that we work somewhat OK with braindead SQLite transaction handling
#
#
# However DBD::SQLite 1.38_02 seems to fix this, with an accompanying test:
# https://metacpan.org/source/ADAMK/DBD-SQLite-1.38_02/t/54_literal_txn.t
-
my $lit_txn_todo = modver_gt_or_eq('DBD::SQLite', '1.38_02')
? undef
: "DBD::SQLite before 1.38_02 is retarded wrt detecting literal BEGIN/COMMIT statements"
}
}
+# test blank begin/svp/commit/begin cycle
+warnings_are {
+ my $schema = DBICTest->init_schema( no_populate => 1 );
+ my $rs = $schema->resultset('Artist');
+ is ($rs->count, 0, 'Start with empty table');
+
+ for my $do_commit (1, 0) {
+ $schema->txn_begin;
+ $schema->svp_begin;
+ $schema->svp_rollback;
+
+ $schema->svp_begin;
+ $schema->svp_rollback;
+
+ $schema->svp_release;
+
+ $schema->svp_begin;
+
+ $schema->txn_rollback;
+
+ $schema->txn_begin;
+ $schema->svp_begin;
+ $schema->svp_rollback;
+
+ $schema->svp_begin;
+ $schema->svp_rollback;
+
+ $schema->svp_release;
+
+ $schema->svp_begin;
+
+ $do_commit ? $schema->txn_commit : $schema->txn_rollback;
+
+ is_deeply $schema->storage->savepoints, [], 'Savepoint names cleared away'
+ }
+
+ $schema->txn_do(sub {
+ ok (1, 'all seems fine');
+ });
+} [], 'No warnings emitted';
my $schema = DBICTest->init_schema();
is ($row->rank, 'abc', 'proper rank inserted into database');
# and make sure we do not lose actual bigints
+SKIP: {
+
+skip "Not testing bigint handling on known broken DBD::SQLite trial versions", 1
+ if modver_gt_or_eq_and_lt( 'DBD::SQLite', '1.45', '1.45_03' );
+
{
package DBICTest::BigIntArtist;
use base 'DBICTest::Schema::Artist';
$_[1]->do('ALTER TABLE artist ADD COLUMN bigint BIGINT');
});
-my $sqlite_broken_bigint = (
- modver_gt_or_eq('DBD::SQLite', '1.34') and ! modver_gt_or_eq('DBD::SQLite', '1.37')
-);
+my $sqlite_broken_bigint = modver_gt_or_eq_and_lt( 'DBD::SQLite', '1.34', '1.37' );
# 63 bit integer
my $many_bits = (Math::BigInt->new(2) ** 62);
1
2
- -9223372036854775808
-9223372036854775807
-8694837494948124658
-6848440844435891639
$sqlite_broken_bigint
? ()
: ( '2147483648', '2147483649' )
+ ,
+
+ # with newer compilers ( gcc 4.9+ ) older DBD::SQLite does not
+ # play well with the "Most Negative Number"
+ modver_gt_or_eq( 'DBD::SQLite', '1.33' )
+ ? ( '-9223372036854775808' )
+ : ()
+ ,
+
) {
# unsigned 32 bit ints have a range of −2,147,483,648 to 2,147,483,647
# alternatively expressed as the hexadecimal numbers below
my $v_desc = sprintf '%s (%d bit signed int)', $bi, $v_bits;
my @w;
- local $SIG{__WARN__} = sub { $_[0] =~ /datatype mismatch/ ? push @w, @_ : warn @_ };
+ local $SIG{__WARN__} = sub {
+ if ($_[0] =~ /datatype mismatch/) {
+ push @w, @_;
+ }
+ elsif ($_[0] =~ /An integer value occupying more than 32 bits was supplied .+ can not bind properly so DBIC will treat it as a string instead/ ) {
+ # do nothing, this warning will pop up here and there depending on
+ # DBD/bitness combination
+ # we don't want to test for it explicitly, we are just interested
+ # in the results matching at the end
+ }
+ else {
+ warn @_;
+ }
+ };
# some combinations of SQLite 1.35 and older 5.8 faimly is wonky
# instead of a warning we get a full exception. Sod it
eval {
$row = $schema->resultset('BigIntArtist')->create({ bigint => $bi });
} or do {
- fail("Exception on inserting $v_desc") unless $sqlite_broken_bigint;
+ fail("Exception on inserting $v_desc: $@") unless $sqlite_broken_bigint;
next;
};
"value in database correct ($v_desc)"
);
-# FIXME - temporary smoke-only escape
-SKIP: {
- skip 'Potential for false negatives - investigation pending', 1
- if DBICTest::RunMode->is_plain;
-
# check if math works
# start by adding/subtracting a 50 bit integer, and then divide by 2 for good measure
my ($sqlop, $expect) = $bi < 0
, "simple integer math with@{[ $dtype ? '' : 'out' ]} bindtype in database correct (base $v_desc)")
or diag sprintf '%s != %s', $row->bigint, $expect;
}
-# end of fixme
-}
is_deeply (\@w, [], "No mismatch warnings on bigint operations ($v_desc)" );
-}
+
+}}
done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
-my $orig_debug = $schema->storage->debug;
-
-# test the abstract join => SQL generator
-my $sa = new DBIx::Class::SQLMaker;
-
-my @j = (
- { child => 'person' },
- [ { father => 'person' }, { 'father.person_id' => 'child.father_id' }, ],
- [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-my $match = 'person child JOIN person father ON ( father.person_id = '
- . 'child.father_id ) JOIN person mother ON ( mother.person_id '
- . '= child.mother_id )'
- ;
-is_same_sql(
- $sa->_recurse_from(@j),
- $match,
- 'join 1 ok'
-);
-
-my @j2 = (
- { mother => 'person' },
- [ [ { child => 'person' },
- [ { father => 'person' },
- { 'father.person_id' => 'child.father_id' }
- ]
- ],
- { 'mother.person_id' => 'child.mother_id' }
- ],
-);
-$match = 'person mother JOIN (person child JOIN person father ON ('
- . ' father.person_id = child.father_id )) ON ( mother.person_id = '
- . 'child.mother_id )'
- ;
-is_same_sql(
- $sa->_recurse_from(@j2),
- $match,
- 'join 2 ok'
-);
-
-
-my @j3 = (
- { child => 'person' },
- [ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ],
- [ { mother => 'person', -join_type => 'inner' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-$match = 'person child INNER JOIN person father ON ( father.person_id = '
- . 'child.father_id ) INNER JOIN person mother ON ( mother.person_id '
- . '= child.mother_id )'
- ;
-
-is_same_sql(
- $sa->_recurse_from(@j3),
- $match,
- 'join 3 (inner join) ok'
-);
-
-my @j4 = (
- { mother => 'person' },
- [ [ { child => 'person', -join_type => 'left' },
- [ { father => 'person', -join_type => 'right' },
- { 'father.person_id' => 'child.father_id' }
- ]
- ],
- { 'mother.person_id' => 'child.mother_id' }
- ],
-);
-$match = 'person mother LEFT JOIN (person child RIGHT JOIN person father ON ('
- . ' father.person_id = child.father_id )) ON ( mother.person_id = '
- . 'child.mother_id )'
- ;
-is_same_sql(
- $sa->_recurse_from(@j4),
- $match,
- 'join 4 (nested joins + join types) ok'
-);
-
-my @j5 = (
- { child => 'person' },
- [ { father => 'person' }, { 'father.person_id' => \'!= child.father_id' }, ],
- [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-$match = 'person child JOIN person father ON ( father.person_id != '
- . 'child.father_id ) JOIN person mother ON ( mother.person_id '
- . '= child.mother_id )'
- ;
-is_same_sql(
- $sa->_recurse_from(@j5),
- $match,
- 'join 5 (SCALAR reference for ON statement) ok'
-);
-
my $rs = $schema->resultset("CD")->search(
{ 'year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
- { from => [ { 'me' => 'cd' },
- [
- { artist => 'artist' },
- { 'me.artist' => 'artist.artistid' }
- ] ] }
+ { from => [
+ { 'me' => 'cd' },
+ [
+ { artist => 'artist' },
+ { 'me.artist' => { -ident => 'artist.artistid' } },
+ ],
+ ] }
);
is( $rs + 0, 1, "Single record in resultset");
use Test::More;
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
is ($subsel->count, 2, 'Subselect correctly limited the rs to 2 cds');
is ($subsel->next->title, $cds->next->title, 'First CD title match');
is ($subsel->next->title, $cds->next->title, 'Second CD title match');
+$cds->reset;
is($schema->resultset('CD')->current_source_alias, "me", '$rs->current_source_alias returns "me"');
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
my $schema = DBICTest->init_schema();
{
my $artist = $schema->resultset('Artist')->find(1);
- my ($sql, @bind);
- my $old_debugobj = $schema->storage->debugobj;
- my $old_debug = $schema->storage->debug;
- $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
- $schema->storage->debug(1);
-
- $artist->discard_changes;
-
- is_same_sql_bind (
- $sql,
- \@bind,
- 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE me.artistid = ?',
- [qw/'1'/],
- );
-
- $schema->storage->debug($old_debug);
- $schema->storage->debugobj($old_debugobj);
+ $schema->is_executed_sql_bind( sub { $artist->discard_changes }, [
+ [
+ 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE me.artistid = ?',
+ [ { dbic_colname => "me.artistid", sqlt_datatype => "integer" } => 1 ],
+ ]
+ ], 'Expected query on discard_changes');
}
{
is($cover_cds->count, $artist_cds->count, 'duplicated rows count ok');
#check multi-keyed
-cmp_ok($cover_band->search_related('twokeys')->count, '>', 0, 'duplicated multiPK ok');
+is(
+ $cover_band->search_related('twokeys')->count,
+ $artist->search_related('twokeys')->count,
+ 'duplicated multiPK ok'
+);
#and check copying a few relations away
cmp_ok($cover_cds->search_related('tags')->count, '==',
$artist_cds->search_related('tags')->count , 'duplicated count ok');
+
+# check from the other side
+my $cd = $schema->resultset('CD')->find(1);
+my $dup_cd = $cd->copy ({ title => 'ha!' });
+is(
+ $dup_cd->search_related('twokeys')->count,
+ $cd->search_related('twokeys')->count,
+ 'duplicated multiPK ok'
+);
+
done_testing;
my $schema = DBICTest->init_schema();
-my $queries;
-my $debugcb = sub{ $queries++ };
-my $sdebug = $schema->storage->debug;
-
-plan tests => 23;
-
my $rs = $schema->resultset("Artist")->search(
{ artistid => 1 }
);
$rs->clear_cache;
-$queries = 0;
-$schema->storage->debug(1);
-$schema->storage->debugcb ($debugcb);
-
-$rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
-while( $artist = $rs->next ) {}
-$artist = $rs->first();
-
-is( $queries, 1, 'revisiting a row does not issue a query when cache => 1' );
+$schema->is_executed_querycount( sub {
-$schema->storage->debug($sdebug);
-$schema->storage->debugcb (undef);
+ $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
+ while( $artist = $rs->next ) {}
+ $artist = $rs->first();
+}, 1, 'revisiting a row does not issue a query when cache => 1' );
my @a = $schema->resultset("Artist")->search(
{ },
}
);
-# start test for prefetch SELECT count
-$queries = 0;
-$schema->storage->debug(1);
-$schema->storage->debugcb ($debugcb);
-
-$artist = $rs->first;
-$rs->reset();
+# prefetch SELECT count
+$schema->is_executed_querycount( sub {
+ $artist = $rs->first;
+ $rs->reset();
-# make sure artist contains a related resultset for cds
-isa_ok( $artist->{related_resultsets}{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' );
+ # make sure artist contains a related resultset for cds
+ isa_ok( $artist->{related_resultsets}{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' );
-# check if $artist->cds->get_cache is populated
-is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records');
+ # check if $artist->cds->get_cache is populated
+ is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records');
-# ensure that $artist->cds returns correct number of objects
-is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' );
+ # ensure that $artist->cds returns correct number of objects
+ is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' );
-# ensure that $artist->cds->count returns correct value
-is( $artist->cds->count, 3, 'artist->cds->count returns correct value' );
+ # ensure that $artist->cds->count returns correct value
+ is( $artist->cds->count, 3, 'artist->cds->count returns correct value' );
-# ensure that $artist->count_related('cds') returns correct value
-is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' );
+ # ensure that $artist->count_related('cds') returns correct value
+ is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' );
-is($queries, 1, 'only one SQL statement executed');
+}, 1, 'only one SQL statement executed');
-$schema->storage->debug($sdebug);
-$schema->storage->debugcb (undef);
# make sure related_resultset is deleted after object is updated
$artist->set_column('name', 'New Name');
}
# SELECT count for nested has_many prefetch
-$queries = 0;
-$schema->storage->debug(1);
-$schema->storage->debugcb ($debugcb);
-
-$artist = ($rs->all)[0];
-
-is($queries, 1, 'only one SQL statement executed');
-
-$queries = 0;
-
-my @objs;
-my $cds = $artist->cds;
-my $tags = $cds->next->tags;
-while( my $tag = $tags->next ) {
- push @objs, $tag->tagid; #warn "tag:", $tag->ID, " => ", $tag->tag;
-}
-
-is_deeply( \@objs, [ 3 ], 'first cd has correct tags' );
-
-$tags = $cds->next->tags;
-@objs = ();
-while( my $tag = $tags->next ) {
- push @objs, $tag->id; #warn "tag: ", $tag->ID;
-}
-
-is_deeply( [ sort @objs] , [ 2, 5, 8 ], 'third cd has correct tags' );
-
-$tags = $cds->next->tags;
-@objs = ();
-while( my $tag = $tags->next ) {
- push @objs, $tag->id; #warn "tag: ", $tag->ID;
-}
-
-is_deeply( \@objs, [ 1 ], 'second cd has correct tags' );
+$schema->is_executed_querycount( sub {
+ $artist = ($rs->all)[0];
+}, 1, 'only one SQL statement executed');
+
+$schema->is_executed_querycount( sub {
+ my @objs;
+ my $cds = $artist->cds;
+ my $tags = $cds->next->tags;
+ while( my $tag = $tags->next ) {
+ push @objs, $tag->tagid; #warn "tag:", $tag->ID, " => ", $tag->tag;
+ }
-is( $queries, 0, 'no additional SQL statements while checking nested data' );
+ is_deeply( \@objs, [ 3 ], 'first cd has correct tags' );
-# start test for prefetch SELECT count
-$queries = 0;
+ $tags = $cds->next->tags;
+ @objs = ();
+ while( my $tag = $tags->next ) {
+ push @objs, $tag->id; #warn "tag: ", $tag->ID;
+ }
-$artist = $schema->resultset('Artist')->find(1, { prefetch => [qw/cds/] });
+ is_deeply( [ sort @objs] , [ 2, 5, 8 ], 'third cd has correct tags' );
-is( $queries, 1, 'only one select statement on find with inline has_many prefetch' );
+ $tags = $cds->next->tags;
+ @objs = ();
+ while( my $tag = $tags->next ) {
+ push @objs, $tag->id; #warn "tag: ", $tag->ID;
+ }
-# start test for prefetch SELECT count
-$queries = 0;
+ is_deeply( \@objs, [ 1 ], 'second cd has correct tags' );
+}, 0, 'no additional SQL statements while checking nested data' );
-$rs = $schema->resultset('Artist')->search(undef, { prefetch => [qw/cds/] });
-$artist = $rs->find(1);
+$schema->is_executed_querycount( sub {
+ $artist = $schema->resultset('Artist')->find(1, { prefetch => [qw/cds/] });
+}, 1, 'only one select statement on find with inline has_many prefetch' );
-is( $queries, 1, 'only one select statement on find with has_many prefetch on resultset' );
+$schema->is_executed_querycount( sub {
+ $rs = $schema->resultset('Artist')->search(undef, { prefetch => [qw/cds/] });
+ $artist = $rs->find(1);
+}, 1, 'only one select statement on find with has_many prefetch on resultset' );
-$schema->storage->debug($sdebug);
-$schema->storage->debugcb (undef);
+done_testing;
# Test resultsource with cached rows
- my $query_count;
- $cd_rs = $cd_rs->search ({}, { cache => 1 });
+ $schema->is_executed_querycount( sub {
+ $cd_rs = $cd_rs->search ({}, { cache => 1 });
- my $orig_debug = $schema->storage->debug;
- $schema->storage->debug(1);
- $schema->storage->debugcb(sub { $query_count++ } );
+ # this will hit the database once and prime the cache
+ my @cds = $cd_rs->all;
- # this will hit the database once and prime the cache
- my @cds = $cd_rs->all;
-
- lives_ok {
$copy = $store->($cd_rs);
ref_ne($copy, $cd_rs, 'Cached resultset cloned');
is_deeply (
);
is ($copy->count, $cd_rs->count, 'Cached count identical');
- } "serialize cached resultset lives: $name";
-
- is ($query_count, 1, 'Only one db query fired');
-
- $schema->storage->debug($orig_debug);
- $schema->storage->debugcb(undef);
+ }, 1, 'Only one db query fired');
}
# test schema-less detached thaw
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj;
{
package A::Comp;
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components('UTF8Columns');
DBICTest::Schema::CD->utf8_columns('title');
-Class::C3->reinitialize();
+Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
# as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8
binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
utf8::encode($bytestream_title);
cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)');
-my $storage = $schema->storage;
-my ($sql, @bind);
-my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
-my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
-$storage->debugobj ($debugobj);
-$storage->debug (1);
-
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } );
-
-$storage->debugobj ($orig_debugobj);
-$storage->debug ($orig_debug);
-
-# bind values are always alphabetically ordered by column, thus [1]
-# the single quotes are an artefact of the debug-system
+my $cd;
{
local $TODO = "This has been broken since rev 1191, Mar 2006";
- is ($bind[1], "'$bytestream_title'", 'INSERT: raw bytes sent to the database');
-}
+
+ $schema->is_executed_sql_bind( sub {
+ $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } )
+ }, [[
+ 'INSERT INTO cd ( artist, title, year) VALUES ( ?, ?, ? )',
+ [ { dbic_colname => "artist", sqlt_datatype => "integer" }
+ => 1 ],
+ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => $bytestream_title ],
+ [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => 2048 ],
+ ]], 'INSERT: raw bytes sent to the database' );
+};
# this should be using the cursor directly, no inflation/processing of any sort
my ($raw_db_title) = $schema->resultset('CD')
$bytestream_title = $utf8_title = "something \x{219} else";
utf8::encode($bytestream_title);
+$schema->is_executed_sql_bind( sub {
+ $cd->update ({ title => $utf8_title });
+}, [
+ [ 'BEGIN' ],
+ [
+ 'UPDATE cd SET title = ? WHERE cdid = ?',
+ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => $bytestream_title ],
+ [ { dbic_colname => "cdid", sqlt_datatype => "integer" }
+ => 6 ],
+ ],
+ [ 'COMMIT' ],
+], 'UPDATE: raw bytes sent to the database');
-$storage->debugobj ($debugobj);
-$storage->debug (1);
-
-$cd->update ({ title => $utf8_title });
-
-$storage->debugobj ($orig_debugobj);
-$storage->debug ($orig_debug);
-
-is ($bind[0], "'$bytestream_title'", 'UPDATE: raw bytes sent to the database');
($raw_db_title) = $schema->resultset('CD')
->search ($cd->ident_condition)
->get_column('title')
my $schema = DBICTest->init_schema();
-my $queries;
-$schema->storage->debugcb( sub{ $queries++ } );
-my $sdebug = $schema->storage->debug;
-
my $cd = $schema->resultset("CD")->find(1);
$cd->title('test');
-# SELECT count
-$queries = 0;
-$schema->storage->debug(1);
-
-$cd->update;
-
-is($queries, 1, 'liner_notes (might_have) not prefetched - do not load
-liner_notes on update');
-
-$schema->storage->debug($sdebug);
-
+$schema->is_executed_querycount( sub {
+ $cd->update;
+}, {
+ BEGIN => 1,
+ UPDATE => 1,
+ COMMIT => 1,
+}, 'liner_notes (might_have) not prefetched - do not load liner_notes on update' );
my $cd2 = $schema->resultset("CD")->find(2, {prefetch => 'liner_notes'});
$cd2->title('test2');
-# SELECT count
-$queries = 0;
-$schema->storage->debug(1);
-
-$cd2->update;
-
-is($queries, 1, 'liner_notes (might_have) prefetched - do not load
-liner_notes on update');
+$schema->is_executed_querycount( sub {
+ $cd2->update;
+}, {
+ BEGIN => 1,
+ UPDATE => 1,
+ COMMIT => 1,
+}, 'liner_notes (might_have) prefetched - do not load liner_notes on update');
warning_like {
local $ENV{DBIC_DONT_VALIDATE_RELS};
'Setting DBIC_DONT_VALIDATE_RELS suppresses nullable relation warnings';
}
-$schema->storage->debug($sdebug);
done_testing();
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy';
+
use strict;
use warnings;
use Test::More;
use Test::Warn;
-use lib qw(t/lib);
-use DBICTest;
-
use Scalar::Util 'blessed';
-BEGIN {
- require DBIx::Class;
- plan skip_all =>
- 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
-}
+use lib qw(t/lib);
+use DBICTest;
my $custom_deployment_statements_called = 0;
return $self->next::method(@_);
}
-
# Check deployment statements ctx sensitivity
{
- my $schema = DBICTest->init_schema (no_deploy => 1);
+ my $schema = DBICTest->init_schema (no_deploy => 1, quote_names => 1);
my $not_first_table_creation_re = qr/CREATE TABLE "fourkeys_to_twokeys"/;
my $statements = $schema->deployment_statements;
use lib qw(t/lib);
use DBICTest;
-use POSIX qw(ceil);
+use POSIX ();
my $schema = DBICTest->init_schema();
$to_pos++;
$to_group = ($to_group % 3) + 1;
$to_group_2_base++;
- $to_group_2 = (ceil($to_group_2_base/3.0) %3) +1
+ $to_group_2 = (
+ POSIX::ceil( $to_group_2_base / 3.0 ) % 3
+ ) + 1;
}
}
foreach my $group_id_2 (1..4) {
use Test::More;
use Test::Warn;
use Test::Exception;
+
+# MASSIVE FIXME - there is a hole in ::RSC / as_subselect_rs
+# losing the order. Needs a rework/extract of the realiaser,
+# and that's a whole another bag of dicks
+BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 }
+
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
cmp_ok($rs_year->sum, '==', 9996, "three artists returned");
-my $rso_year = $rs->search({}, { order_by => 'cdid' })->get_column('year');
-is($rso_year->next, 1999, "reset okay");
+{
+ my $rso_year = $rs->search({}, { order_by => 'cdid' })->get_column('year');
+ is($rso_year->next, 1999, "reset okay");
-is($rso_year->first, 1999, "first okay");
+ is($rso_year->first, 1999, "first okay");
-warnings_exist (sub {
- is($rso_year->single, 1999, "single okay");
-}, qr/Query returned more than one row/, 'single warned');
+ warnings_exist (sub {
+ is($rso_year->single, 1999, "single okay");
+ }, qr/Query returned more than one row/, 'single warned');
+}
# test distinct propagation
$schema->resultset('CD')->create({ artist => 1, title => 'dealbroker no tracks', year => 2001 });
+ my $yp1 = \[ 'year + ?', 1 ];
+
my $rs = $schema->resultset ('CD')->search (
{ 'artist.name' => { '!=', 'evancarrol' }, 'tracks.trackid' => { '!=', undef } },
{
order_by => 'me.year',
join => [qw(artist tracks)],
- columns => [ 'year', { cnt => { count => 'me.cdid' }} ],
+ columns => [
+ 'year',
+ { cnt => { count => 'me.cdid' } },
+ { year_plus_one => $yp1 },
+ ],
},
);
my $rstypes = {
- 'explicitly grouped' => $rs->search_rs({}, { group_by => 'year' }),
+ 'explicitly grouped' => $rs->search_rs({}, { group_by => [ 'year', $yp1 ] } ),
'implicitly grouped' => $rs->search_rs({}, { distinct => 1 }),
};
# would silently drop the group_by entirely, likely ending up with nonsensival results
# With the current behavior the user will at least get a nice fat exception from the
# RDBMS (or maybe the RDBMS will even decide to handle the situation sensibly...)
- warnings_exist { is_same_sql_bind(
- $rstypes->{'implicitly grouped'}->get_column('cnt')->as_query,
- '(
- SELECT COUNT( me.cdid )
- FROM cd me
- JOIN artist artist
- ON artist.artistid = me.artist
- LEFT JOIN track tracks
- ON tracks.cd = me.cdid
- WHERE artist.name != ? AND tracks.trackid IS NOT NULL
- GROUP BY COUNT( me.cdid )
- ORDER BY MIN(me.year)
- )',
- [ [ { dbic_colname => 'artist.name', sqlt_datatype => 'varchar', sqlt_size => 100 }
- => 'evancarrol'
- ] ],
- 'Expected (though nonsensical) SQL generated on rscol-with-distinct-over-function',
- ) } qr/
- \QUse of distinct => 1 while selecting anything other than a column \E
- \Qdeclared on the primary ResultSource is deprecated\E
- /x, 'deprecation warning';
+ for (
+ [ cnt => 'COUNT( me.cdid )' ],
+ [ year_plus_one => 'year + ?' => [ {} => 1 ] ],
+ ) {
+ my ($col, $sel_grp_sql, @sel_grp_bind) = @$_;
+
+ warnings_exist { is_same_sql_bind(
+ $rstypes->{'implicitly grouped'}->get_column($col)->as_query,
+ "(
+ SELECT $sel_grp_sql
+ FROM cd me
+ JOIN artist artist
+ ON artist.artistid = me.artist
+ LEFT JOIN track tracks
+ ON tracks.cd = me.cdid
+ WHERE artist.name != ? AND tracks.trackid IS NOT NULL
+ GROUP BY $sel_grp_sql
+ ORDER BY MIN(me.year)
+ )",
+ [
+ @sel_grp_bind,
+ [ { dbic_colname => 'artist.name', sqlt_datatype => 'varchar', sqlt_size => 100 }
+ => 'evancarrol' ],
+ @sel_grp_bind,
+ ],
+ 'Expected (though nonsensical) SQL generated on rscol-with-distinct-over-function',
+ ) } qr/
+ \QUse of distinct => 1 while selecting anything other than a column \E
+ \Qdeclared on the primary ResultSource is deprecated (you selected '$col')\E
+ /x, 'deprecation warning';
+ }
{
local $TODO = 'multiplying join leaks through to the count aggregate... this may never actually work';
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
lives_ok (sub {
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
{ # Fake storage driver for sqlite with autocast
package DBICTest::SQLite::AutoCast;
'me.single_track' => \[ '= ?', [ single_track => 1 ] ],
}, { join => 'tracks' });
-my ($sql, @bind);
-my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
-my $storage = $schema->storage;
-my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
-$storage->debugobj ($debugobj);
-$storage->debug (1);
-
-# the quoting is a debugobj thing, not dbic-internals
-my $bind = [ map { "'$_'" } qw/
- 5 1 2009 4
-/];
+my @bind = (
+ [ { dbic_colname => "cdid", sqlt_datatype => "integer" }
+ => 5 ],
+ [ { dbic_colname => "single_track", sqlt_datatype => "integer" }
+ => 1 ],
+ [ { dbic_colname => "tracks.last_updated_on", sqlt_datatype => "datetime" }
+ => 2009 ],
+ [ { dbic_colname => "tracks.position", sqlt_datatype => "int" }
+ => 4 ],
+);
-$rs->all;
-is_same_sql_bind (
- $sql,
- \@bind,
+$schema->is_executed_sql_bind( sub { $rs->all }, [[
'
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
AND tracks.last_updated_on < ?
AND tracks.position = ?
',
- $bind,
- 'expected sql with casting off',
-);
+ @bind,
+]], 'expected sql with casting off' );
$schema->storage->auto_cast (1);
-$rs->all;
-is_same_sql_bind (
- $sql,
- \@bind,
+$schema->is_executed_sql_bind( sub { $rs->all }, [[
'
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
AND tracks.last_updated_on < CAST (? AS DateTime)
AND tracks.position = ?
',
- $bind,
- 'expected sql with casting on',
-);
-
-$storage->debugobj ($orig_debugobj);
-$storage->debug ($orig_debug);
+ @bind,
+]], 'expected sql with casting on' );
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw(deploy test_rdbms_mysql);
+
use strict;
use warnings;
use DBICTest;
use DBIx::Class::_Util 'sigwarn_silencer';
-my ($dsn, $user, $pass);
-
-BEGIN {
- ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
-
- plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
- unless ($dsn);
-
- require DBIx::Class;
- plan skip_all =>
- 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy');
-
- plan skip_all =>
- 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql');
-}
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
# this is just to grab a lock
{
ok($get_db_version_run == 0, "attributes pulled from list connect_info");
}
+# at this point we have v1, v2 and v3 still connected
+# make sure they are the only connections and everything else is gone
+is
+ scalar( grep
+ { defined $_ and $_->{Active} }
+ map
+ { @{$_->{ChildHandles}} }
+ values %{ { DBI->installed_drivers } }
+ ), 3, "Expected number of connections at end of script"
+;
+
END {
unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
$ddl_dir->rmtree;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use DBIx::Class::Optional::Dependencies ();
-
-my $env2optdep = {
- DBICTEST_PG => 'rdbms_pg',
- DBICTEST_MYSQL => 'test_rdbms_mysql',
-};
-
-plan skip_all => join (' ',
- 'Set $ENV{DBICTEST_PG_DSN} and/or $ENV{DBICTEST_MYSQL_DSN} _USER and _PASS to run these tests.',
-) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::Stats;
-
-my $schema;
-
-for my $prefix (keys %$env2optdep) { SKIP: {
- my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
-
- skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1)
- unless $dsn;
-
- skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
- unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
-
- $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
-
- my $create_sql;
- $schema->storage->ensure_connected;
- if ($schema->storage->isa('DBIx::Class::Storage::DBI::Pg')) {
- $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
- $schema->storage->dbh->do('SET client_min_messages=WARNING');
- }
- elsif ($schema->storage->isa('DBIx::Class::Storage::DBI::mysql')) {
- $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
- }
- else {
- skip( 'Untested driver ' . $schema->storage, 1 );
- }
-
- note "Testing $prefix";
-
- my $stats = DBICTest::Stats->new;
- $schema->storage->debugobj($stats);
- $schema->storage->debug(1);
-
- $schema->storage->dbh->do ('DROP TABLE IF EXISTS artist');
- $schema->storage->dbh->do ($create_sql);
-
- $schema->resultset('Artist')->create({ name => 'foo' });
-
- $schema->txn_begin;
-
- my $arty = $schema->resultset('Artist')->find(1);
-
- my $name = $arty->name;
-
- # First off, test a generated savepoint name
- $schema->svp_begin;
-
- cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
-
- $arty->update({ name => 'Jheephizzy' });
-
- $arty->discard_changes;
-
- cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
-
- # Rollback the generated name
- # Active: 0
- $schema->svp_rollback;
-
- cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
-
- $arty->discard_changes;
-
- cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
-
- $arty->update({ name => 'Jheephizzy'});
-
- # Active: 0 1
- $schema->svp_begin('testing1');
-
- $arty->update({ name => 'yourmom' });
-
- # Active: 0 1 2
- $schema->svp_begin('testing2');
-
- $arty->update({ name => 'gphat' });
- $arty->discard_changes;
- cmp_ok($arty->name, 'eq', 'gphat', 'name changed');
- # Active: 0 1 2
- # Rollback doesn't DESTROY the savepoint, it just rolls back to the value
- # at its conception
- $schema->svp_rollback('testing2');
- $arty->discard_changes;
- cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted');
-
- # Active: 0 1 2 3
- $schema->svp_begin('testing3');
- $arty->update({ name => 'coryg' });
- # Active: 0 1 2 3 4
- $schema->svp_begin('testing4');
- $arty->update({ name => 'watson' });
-
- # Release 3, which implicitly releases 4
- # Active: 0 1 2
- $schema->svp_release('testing3');
- $arty->discard_changes;
- cmp_ok($arty->name, 'eq', 'watson', 'release left data');
- # This rolls back savepoint 2
- # Active: 0 1 2
- $schema->svp_rollback;
- $arty->discard_changes;
- cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2');
-
- # Rollback the original savepoint, taking us back to the beginning, implicitly
- # rolling back savepoint 1 and 2
- $schema->svp_rollback('savepoint_0');
- $arty->discard_changes;
- cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start');
-
- $schema->txn_commit;
-
- # And now to see if txn_do will behave correctly
- $schema->txn_do (sub {
- my $artycp = $arty;
-
- $schema->txn_do (sub {
- $artycp->name ('Muff');
- $artycp->update;
- });
-
- eval {
- $schema->txn_do (sub {
- $artycp->name ('Moff');
- $artycp->update;
- $artycp->discard_changes;
- is($artycp->name,'Moff','Value updated in nested transaction');
- $schema->storage->dbh->do ("GUARANTEED TO PHAIL");
- });
- };
-
- ok ($@,'Nested transaction failed (good)');
-
- $arty->discard_changes;
-
- is($arty->name,'Muff','auto_savepoint rollback worked');
-
- $arty->name ('Miff');
-
- $arty->update;
- });
-
- $arty->discard_changes;
-
- is($arty->name,'Miff','auto_savepoint worked');
-
- cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created');
-
- cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released');
-
- cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
-
- $schema->storage->dbh->do ("DROP TABLE artist");
-}}
-
-done_testing;
-
-END {
- eval { $schema->storage->dbh->do ("DROP TABLE artist") } if defined $schema;
- undef $schema;
-}
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy';
+
use strict;
use warnings;
+BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 }
+
use Test::More;
use Test::Warn;
use Test::Exception;
use DBICTest;
use DBIx::Class::_Util 'sigwarn_silencer';
-BEGIN {
- require DBIx::Class;
- plan skip_all =>
- 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
-}
-
# Test for SQLT-related leaks
{
my $s = DBICTest::Schema->clone;
# make sure a connected instance passed via $args does not get the $dbh improperly serialized
SKIP: {
- # YAML is a build_requires dep of SQLT - it may or may not be here
- eval { require YAML } or skip "Test requires YAML.pm", 1;
+ DBIx::Class::Optional::Dependencies->skip_without( 'YAML>=0' );
lives_ok {
}, 'partial schema tests successful');
}
+{
+ my $cd_rsrc = $schema->source('CD');
+ $cd_rsrc->name(\'main.cd');
+
+ my $sqlt_schema = create_schema(
+ { schema => $schema },
+ args => { ignore_constraint_names => 0, ignore_index_names => 0 }
+ );
+
+ foreach my $source_name (qw(CD)) {
+ my $table = get_table($sqlt_schema, $schema, $source_name);
+ ok(
+ !(grep {$_->name =~ m/main\./} $table->get_indices),
+ 'indices have periods stripped out'
+ );
+ ok(
+ !(grep {$_->name =~ m/main\./} $table->get_constraints),
+ 'constraints have periods stripped out'
+ );
+ }
+}
+
done_testing;
sub create_schema {
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use DBICTest;
-
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
-}
-
-use_ok 'DBIx::Class::Admin';
-
-
-done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( admin deploy );
+
use strict;
use warnings;
use DBICTest;
use DBIx::Class::_Util 'sigwarn_silencer';
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
-
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
-}
-
-use_ok 'DBIx::Class::Admin';
+use DBIx::Class::Admin;
# lock early
DBICTest->init_schema(no_deploy => 1, no_populate => 1);
);
$admin->version("3.0");
-lives_ok { $admin->install(); } 'install schema version 3.0';
+$admin->install;
is($admin->schema->get_db_version, "3.0", 'db thinks its version 3.0');
-dies_ok { $admin->install("4.0"); } 'cannot install to allready existing version';
+throws_ok {
+ $admin->install("4.0")
+} qr/Schema already has a version. Try upgrade instead/, 'cannot install to allready existing version';
$admin->force(1);
warnings_exist ( sub {
- lives_ok { $admin->install("4.0") } 'can force install to allready existing version'
+ $admin->install("4.0")
}, qr/Forcing install may not be a good idea/, 'Force warning emitted' );
is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0');
}
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'admin';
+
use strict;
use warnings;
use lib 't/lib';
use DBICTest;
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
-}
-
-use_ok 'DBIx::Class::Admin';
-
+use DBIx::Class::Admin;
{ # test data maniplulation functions
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
}
{
- SKIP: {
- skip "No column objects", 1;
+ {
+ local $TODO = "No column objects";
eval { my @grps = State->__grouper->groups_for("Huh"); };
ok $@, "Huh not in groups";
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
use namespace::clean;
$| = 1;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
-}
+use lib 't/cdbi/testlib';
+use Film;
ok(Film->can('db_Main'), 'set_db()');
is(Film->__driver, "SQLite", "Driver set correctly");
}
eval { my $duh = Film->insert; };
-like $@, qr/create needs a hashref/, "needs a hashref";
+like $@, qr/Result object instantiation requires a hashref as argument/, "needs a hashref";
ok +Film->create_test_film;
ok !$film, "It destroys itself";
}
-SKIP: {
- skip "Caching has been removed", 5
- if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+{
# my bad taste is your bad taste
my $btaste = Film->retrieve('Bad Taste');
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use Test::Warn;
# Test lazy loading
#----------------------------------------------------------------------
-INIT {
- use lib 't/cdbi/testlib';
- use Lazy;
-}
+use lib 't/cdbi/testlib';
+use Lazy;
is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri";
is_deeply [ sort Lazy->columns('Essential') ], [qw/opop this/], "Essential";
# Now again for inflated values
SKIP: {
- skip "Requires Date::Simple 3.03", 5 unless eval "use Date::Simple 3.03; 1; ";
+ DBIx::Class::Optional::Dependencies->skip_without( 'Date::Simple>=3.03' );
Lazy->has_a(
orp => 'Date::Simple',
inflate => sub { Date::Simple->new($_[0] . '-01-01') },
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
+use Test::Exception;
+use DBIx::Class::_Util 'sigwarn_silencer';
@YA::Film::ISA = 'Film';
-#local $SIG{__WARN__} = sub { };
-
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
- use Director;
-}
+use lib 't/cdbi/testlib';
+use Film;
+use Director;
Film->create_test_film;
ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
sub fail_with_bad_object {
my ($dir, $codir) = @_;
- eval {
+ throws_ok {
+ local $SIG{__WARN__} = sigwarn_silencer( qr/\Qusually should inherit from the related ResultClass ('Director')/ );
YA::Film->create(
{
Title => 'Tastes Bad',
NumExplodingSheep => 23
}
);
- };
- ok $@, $@;
+ } qr/isn't a Director/;
}
package Foo;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
like $@, qr/class/, "add_to_actors must be object method";
eval { my $pj = $btaste->add_to_actors(%pj_data) };
-like $@, qr/expects a hashref/, "add_to_actors takes hash";
+like $@, qr/Result object instantiation requires a hashref as argument/, "add_to_actors takes hash";
ok(
my $pj = $btaste->add_to_actors(
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
+use Test::Exception;
use lib 't/cdbi/testlib';
use Film;
like $@, qr/fails.*constraint/, "Fails listref constraint";
my $ok = eval { Film->create({ Rating => 'U' }) };
is $@, '', "Can create with rating U";
- SKIP: {
- skip "No column objects", 2;
- ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
- ok +Film->find_column('director')->is_constrained, "Director is not";
+ {
+ local $TODO = "No column objects";
+ lives_ok { Film->find_column('rating')->is_constrained || die } "Rating is constrained";
+ lives_ok { Film->find_column('director')->is_constrained || die } "Director is not";
}
}
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
+use lib 't/cdbi/testlib';
INIT {
- #local $SIG{__WARN__} =
- #sub { like $_[0], qr/clashes with built-in method/, $_[0] };
- use lib 't/cdbi/testlib';
- require Film;
- require Actor;
- require Director;
+ require Film;
+ require Actor;
+ require Director;
- Actor->has_a(film => 'Film');
- Film->has_a(director => 'Director');
+ Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
- sub Class::DBI::sheep { ok 0; }
+ sub Class::DBI::sheep { ok 0; }
}
# Install the deprecation warning intercept here for the rest of the 08 dev cycle
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
+use Test::Exception;
+use DBIx::Class::_Util 'sigwarn_silencer';
use lib 't/cdbi/testlib';
use Film;
});
{
- eval { $btaste->Director($btaste) };
- like $@, qr/Director/, "Can't set film as director";
+ throws_ok { $btaste->Director($btaste) }
+ qr/isn't a Director/, "Can't set film as director";
is $btaste->Director->id, $pj->id, "PJ still the director";
# drop from cache so that next retrieve() is from db
is $sj->id, 'Skippy Jackson', 'Create new director - Skippy';
Film->has_a('CoDirector' => 'Director');
{
- eval { $btaste->CoDirector("Skippy Jackson") };
- is $@, "", "Auto inflates";
+ lives_ok { $btaste->CoDirector("Skippy Jackson") };
isa_ok $btaste->CoDirector, "Director";
is $btaste->CoDirector->id, $sj->id, "To skippy";
}
$pj = Director->retrieve('Peter Jackson');
my $fail;
- eval {
+ throws_ok {
+ local $SIG{__WARN__} = sigwarn_silencer( qr/\Qusually should inherit from the related ResultClass ('Director')/ );
$fail = YA::Film->create({
Title => 'Tastes Bad',
Director => $sj,
Rating => 'R',
NumExplodingSheep => 23
});
- };
- ok $@, "Can't have film as codirector: $@";
+ } qr/isn't a Director/, "Can't have film as codirector";
is $fail, undef, "We didn't get anything";
my $tastes_bad = YA::Film->create({
}
{ # Broken has_a declaration
- eval { Film->has_a(driector => "Director") };
- like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
+ throws_ok{ Film->has_a(driector => "Director") }
+ qr/No such column driector/,
+ "Sensible error from has_a with incorrect column"
+ ;
}
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat test_rdbms_mysql Time::Piece::MySQL>=0 );
+
$| = 1;
use warnings;
use strict;
use Test::More;
use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
-eval { require Time::Piece::MySQL }
- or plan skip_all => 'Time::Piece::MySQL required for this test';
use_ok ('Log');
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use Data::Dumper;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
- use Director;
-}
+use lib 't/cdbi/testlib';
+use Film;
+use Director;
{ # Cascade on delete
Director->has_many(nasties => 'Film');
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Time::Piece>=0 );
+
use strict;
use warnings;
+
use Test::More;
use Test::Warn;
-use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
-eval { require Time::Piece }
- or plan skip_all => 'Time::Piece required for this test';
-
package Temp::DBI;
use base qw(DBIx::Class::CDBICompat);
Temp::DBI->columns(All => qw(id date));
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat );
+
use strict;
use warnings;
-use Test::More;
-use lib qw(t/cdbi/testlib);
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
-BEGIN {
- eval { require DateTime; DateTime->VERSION(0.55) }
- or plan skip_all => 'DateTime 0.55 required for this test';
-}
+use Test::More;
+use lib 't/lib';
+use DBICTest;
my $schema = DBICTest->init_schema();
inflate => sub { DateTime->new( year => shift ) },
deflate => sub { shift->year }
);
-Class::C3->reinitialize;
+Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
# inflation test
my $cd = $schema->resultset("CD")->find(3);
--- /dev/null
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat rdbms_sqlite ic_dt );
+
+use strict;
+use warnings;
+
+# Class::DBI in its infinate wisdom allows implicit inflation
+# and deflation of foriegn clas looups in has_a relationships.
+# for inflate it would call ->new on the foreign_class and for
+# deflate it would "" the column value and allow for overloading
+# of the "" operator.
+
+use Test::More;
+
+use lib 't/cdbi/testlib';
+use ImplicitInflate;
+
+ok(ImplicitInflate->can('db_Main'), 'set_db()');
+is(ImplicitInflate->__driver, "SQLite", 'Driver set correctly');
+
+my $now = DateTime->now;
+
+ImplicitInflate->create({
+ update_datetime => $now,
+ text => "Test Data",
+});
+
+my $implicit_inflate = ImplicitInflate->retrieve(text => 'Test Data');
+
+ok($implicit_inflate->update_datetime->isa('DateTime'), 'Date column inflated correctly');
+is($implicit_inflate->update_datetime => $now, 'Date has correct year');
+
+done_testing;
--- /dev/null
+# Columns in CDBI could be defined as Class::DBI::Column objects rather than
+# or as well as with __PACKAGE__->columns();
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI>=3.000005 );
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 't/cdbi/testlib';
+use ColumnObject;
+
+ok(ColumnObject->can('db_Main'), 'set_db()');
+is(ColumnObject->__driver, 'SQLite', 'Driver set correctly');
+
+ColumnObject->create({
+ columna => 'Test Data',
+ columnb => 'Test Data 2',
+});
+
+my $column_object = ColumnObject->retrieve(columna => 'Test Data');
+$column_object->columnb_as_write('Test Data Written');
+$column_object->update;
+$column_object = ColumnObject->retrieve(columna => 'Test Data');
+
+is($column_object->columna_as_read => 'Test Data', 'Read column via accessor');
+is($column_object->columna => 'Test Data', 'Real column returns right data');
+is($column_object->columnb => 'Test Data Written', 'ColumnB wrote via mutator');
+
+done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
#----------------------------------------------------------------------
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI::Plugin::DeepAbstractSearch>=0 );
+
use strict;
use warnings;
-use Test::More;
-use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
+use Test::More;
-BEGIN {
- eval { require Class::DBI::Plugin::DeepAbstractSearch }
- or plan skip_all => 'Class::DBI::Plugin::DeepAbstractSearch required for this test';
-}
+use lib 't/lib';
+use DBICTest;
my $DB = DBICTest->_sqlite_dbname(sqlite_use_file => 1);;
-use Test::More;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
use strict;
use warnings;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
-}
+use Test::More;
+use lib 't/cdbi/testlib';
+use Film;
Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz");
Film->create({ Title => "Batman", Rating => "PG13" });
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use Test::Warn;
# Emulate that Class::DBI inflates immediately
SKIP: {
- unless (eval { require MyFoo }) {
- my ($err) = $@ =~ /([^\n]+)/;
- skip $err, 3
- }
-
+ DBIx::Class::Optional::Dependencies->skip_without([qw( Date::Simple>=3.03 test_rdbms_mysql )]);
+ require MyFoo;
my $foo = MyFoo->insert({
name => 'Whatever',
tdate => '1949-02-01',
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
-}
+use lib 't/cdbi/testlib';
+use Film;
{
Film->insert({
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
-INIT {
- use lib 't/cdbi/testlib';
-}
+use lib 't/cdbi/testlib';
{
package # hide from PAUSE
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
use Test::More;
-use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
{
package Thing;
use base qw(DBIx::Class::CDBICompat);
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
-use Test::More;
-use Class::Inspector ();
+use Test::More;
use lib 't/cdbi/testlib';
use Director;
-# Test that has_many() will load the foreign class.
+# Test that has_many() will load the foreign class
+require Class::Inspector;
ok !Class::Inspector->loaded( 'Film' );
-ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
+ok eval { Director->has_many( films => 'Film' ); 1; } or diag $@;
my $shan_hua = Director->create({
Name => "Shan Hua",
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
package Foo;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
#----------------------------------------------------------------------
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
-INIT {
- use lib 't/cdbi/testlib';
- require Film;
-}
+use lib 't/cdbi/testlib';
+INIT { require Film }
sub Film::get_test {
my $self = shift;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
use lib 't/cdbi/testlib';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
$| = 1;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
-}
-
-plan skip_all => "Object cache is turned off"
- if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
-
-plan tests => 5;
-
+use lib 't/cdbi/testlib';
+use Film;
ok +Film->create({
Title => 'This Is Spinal Tap',
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
+
use Test::More;
-INIT {
- use lib 't/cdbi/testlib';
- use Film;
-}
+use lib 't/cdbi/testlib';
+use Film;
for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
Film->insert({ Title => $title, Director => 'Peter Jackson' });
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat );
+
use strict;
use warnings;
-use Test::More;
+use Test::More;
use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
-BEGIN {
- eval { require DateTime; DateTime->VERSION(0.55) }
- or plan skip_all => 'DateTime 0.55 required for this test';
-}
-
# Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning.
my @warnings;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat );
+
use strict;
use warnings;
+
use Test::More;
use Test::Exception;
use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-
-BEGIN {
- eval { require DateTime; DateTime->VERSION(0.55) }
- or plan skip_all => 'DateTime 0.55 required for this test';
-}
{
package Thing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';
+
use strict;
use warnings;
use Test::More;
-use lib 't/cdbi/testlib';
-use DBIC::Test::SQLite;
+use lib 't/lib';
+use DBICTest;
DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
);
is( $it->count, 1, "complex abstract count ok" );
-# cleanup globals so we do not trigger the leaktest
-for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
- $_->class_resolver(undef);
- $_->resultset_instance(undef);
- $_->result_source_instance(undef);
-}
-{
- no warnings qw/redefine once/;
- *DBICTest::schema = sub {};
-}
-
done_testing;
--- /dev/null
+package # Hide from PAUSE
+ ColumnObject;
+
+use strict;
+use warnings;
+
+use base 'DBIC::Test::SQLite';
+use Class::DBI::Column;
+
+__PACKAGE__->set_table('column_object');
+
+__PACKAGE__->columns( Primary => 'id' );
+__PACKAGE__->columns( All => (
+ 'id',
+ 'columna',
+ 'columnb',
+ Class::DBI::Column->new('columna' => {accessor => 'columna_as_read'}),
+ Class::DBI::Column->new('columnb' => {mutator => 'columnb_as_write'}),
+));
+
+sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY,
+ columna VARCHAR(20),
+ columnb VARCHAR(20)
+ }
+}
+
+1;
package # hide from PAUSE
DBIC::Test::SQLite;
+use strict;
+use warnings;
+
=head1 NAME
DBIx::Class::Test::SQLite - Base class for running Class::DBI tests against DBIx::Class compat layer, shamelessly ripped from Class::DBI::Test::SQLite
=cut
-use strict;
-use warnings;
-
-use Test::More;
+# adding implicit search criteria to the iterator will alter the test
+# mechanics - leave everything as-is instead, and hope SQLite won't
+# change too much
+BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 }
use lib 't/lib';
use DBICTest;
-BEGIN {
- eval { require DBIx::Class::CDBICompat }
- or plan skip_all => 'Class::DBI required for this test';
-}
-
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/CDBICompat Core DB/);
--- /dev/null
+package # Hide from PAUSE
+ ImplicitInflate;
+
+# Test class for the testing of Implicit inflation
+# in CDBI Classes using Compat layer
+# See t/cdbi/70-implicit_inflate.t
+
+use strict;
+use warnings;
+
+use base 'DBIC::Test::SQLite';
+
+__PACKAGE__->set_table('Date');
+
+__PACKAGE__->columns( Primary => 'id' );
+__PACKAGE__->columns( All => qw/ update_datetime text/);
+
+__PACKAGE__->has_a(
+ update_datetime => 'MyDateStamp',
+);
+
+sub create_sql {
+ # SQLite doesn't support Datetime datatypes.
+ return qq{
+ id INTEGER PRIMARY KEY,
+ update_datetime TEXT,
+ text VARCHAR(20)
+ }
+}
+
+{
+ package MyDateStamp;
+
+ use DateTime::Format::SQLite;
+
+ sub new {
+ my ($self, $value) = @_;
+ return DateTime::Format::SQLite->parse_datetime($value);
+ }
+}
+
+1;
use base 'MyBase';
use Time::Piece::MySQL;
-use POSIX;
+use POSIX ();
__PACKAGE__->set_table();
__PACKAGE__->columns(All => qw/id message datetime_stamp/);
use base qw(DBIx::Class::CDBICompat);
-our $dbh;
-
-my $err;
-if (! $ENV{DBICTEST_MYSQL_DSN} ) {
- $err = 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test';
-}
-elsif ( ! DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql') ) {
- $err = 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
-}
-
-if ($err) {
- my $t = eval { Test::Builder->new };
- if ($t and ! $t->current_test) {
- $t->skip_all ($err);
- }
- else {
- die "$err\n";
- }
-}
-
my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0});
# this is only so we grab a lock on mysql
{
my $x = DBICTest::Schema->connect(@connect);
}
-$dbh = DBI->connect(@connect) or die DBI->errstr;
+our $dbh = DBI->connect(@connect) or die DBI->errstr;
my @table;
-END { $dbh->do("DROP TABLE $_") foreach @table }
+END {
+ $dbh->do("DROP TABLE $_") for @table;
+ undef $dbh;
+}
__PACKAGE__->connection(@connect);
use base 'MyBase';
-use Date::Simple 3.03;
-
__PACKAGE__->set_table();
__PACKAGE__->columns(All => qw/myid name val tdate/);
__PACKAGE__->has_a(
use lib qw(t/lib);
use Test::More;
-use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($ROWS, $OFFSET) = (
{ position => [1,2] },
{ prefetch => [qw/disc lyrics/], rows => 3, offset => 8 },
);
- is ($rs->all, 2, 'Correct number of objects');
-
-
- my ($sql, @bind);
- $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
- $schema->storage->debug(1);
+ my @wherebind = (
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 2 ],
+ );
- is ($rs->count, 2, 'Correct count via count()');
+ is ($rs->all, 2, 'Correct number of objects');
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ is ($rs->count, 2, 'Correct count via count()');
+ }, [[
'SELECT COUNT( * )
FROM cd me
JOIN track tracks ON tracks.cd = me.cdid
JOIN cd disc ON disc.cdid = tracks.cd
WHERE ( ( position = ? OR position = ? ) )
- ',
- [ qw/'1' '2'/ ],
- 'count softlimit applied',
- );
+ ', @wherebind
+ ]], 'count softlimit applied');
my $crs = $rs->count_rs;
is ($crs->next, 2, 'Correct count via count_rs()');
LIMIT ? OFFSET ?
) tracks
)',
- [
- [ { sqlt_datatype => 'int', dbic_colname => 'position' }
- => 1 ],
- [ { sqlt_datatype => 'int', dbic_colname => 'position' }
- => 2 ],
- [$ROWS => 3],
- [$OFFSET => 8],
- ],
+ [ @wherebind, [$ROWS => 3], [$OFFSET => 8] ],
'count_rs db-side limit applied',
);
}
{ 'tracks.position' => [1,2] },
{ prefetch => [qw/tracks artist/], rows => 3, offset => 4 },
);
- is ($rs->all, 1, 'Correct number of objects');
-
- my ($sql, @bind);
- $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
- $schema->storage->debug(1);
+ my @wherebind = (
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 2 ],
+ );
- is ($rs->count, 1, 'Correct count via count()');
+ is ($rs->all, 1, 'Correct number of objects');
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ is ($rs->count, 1, 'Correct count via count()');
+ }, [ [
'SELECT COUNT( * )
FROM (
SELECT cds.cdid
WHERE tracks.position = ? OR tracks.position = ?
GROUP BY cds.cdid
) cds
- ',
- [ qw/'1' '2'/ ],
- 'count softlimit applied',
- );
+ ', @wherebind
+ ]], 'count softlimit applied' );
my $crs = $rs->count_rs;
is ($crs->next, 1, 'Correct count via count_rs()');
LIMIT ? OFFSET ?
) cds
)',
- [
- [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
- => 1 ],
- [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
- => 2 ],
- [ $ROWS => 3],
- [$OFFSET => 4],
- ],
+ [ @wherebind, [$ROWS => 3], [$OFFSET => 4], ],
'count_rs db-side limit applied',
);
}
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
use DBICTest;
-plan tests => 7;
-
my $schema = DBICTest->init_schema();
my $cds = $schema->resultset("CD")->search({ cdid => 1 }, { join => { cd_to_producer => 'producer' } });
cmp_ok($cds->count, '>', 1, "extra joins explode entity count");
-is (
- $cds->search({}, { prefetch => 'cd_to_producer' })->count,
- 1,
- "Count correct with extra joins collapsed by prefetch"
-);
-
-is (
- $cds->search({}, { distinct => 1 })->count,
- 1,
- "Count correct with requested distinct collapse of main table"
-);
+for my $arg (
+ [ 'prefetch-collapsed has_many' => { prefetch => 'cd_to_producer' } ],
+ [ 'distict-collapsed result' => { distinct => 1 } ],
+ [ 'explicit collapse request' => { collapse => 1 } ],
+) {
+ for my $hri (0,1) {
+ my $diag = $arg->[0] . ($hri ? ' with HRI' : '');
+
+ my $rs = $cds->search({}, {
+ %{$arg->[1]},
+ $hri ? ( result_class => 'DBIx::Class::ResultClass::HashRefInflator' ) : (),
+ });
+
+ is
+ $rs->count,
+ 1,
+ "Count correct on $diag",
+ ;
+
+ is
+ scalar $rs->all,
+ 1,
+ "Amount of constructed objects matches count on $diag",
+ ;
+ }
+}
# JOIN and LEFT JOIN issues mean that we've seen problems where counted rows and fetched rows are sometimes 1 higher than they should
# be in the related resultset.
my $artist_rs = $schema->resultset('Artist')->search({artistid => $artist->id});
is($artist_rs->related_resultset('cds')->count(), 0, "No CDs counted for a shiny new artist using a resultset search");
is(scalar($artist_rs->related_resultset('cds')->all), 0, "No CDs fetched for a shiny new artist using a resultset search");
+
+done_testing;
use lib qw(t/lib);
use Test::More;
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
my $schema = DBICTest->init_schema();
$schema->_unregister_source('CD');
-warnings_like {
+warnings_exist {
my $s = $schema;
lives_ok {
$_->delete for $s->resultset('Artist')->all;
} 'delete on rows with dangling rels lives';
} [
- # 12 == 3 artists * failed cascades:
+ # 9 == 3 artists * failed cascades:
# cds
# cds_unordered
# cds_very_very_very_long_relationship_name
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( test_rdbms_sqlite ic_dt );
+
use strict;
use warnings;
my $schema = DBICTest->init_schema();
-plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
-
$schema->class('CD') ->inflate_column( 'year',
{ inflate => sub { DateTime->new( year => shift ) },
deflate => sub { shift->year } }
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_firebird_common );
+
use strict;
use warnings;
use Test::More;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
-use Scope::Guard ();
my $env2optdep = {
DBICTEST_FIREBIRD => 'test_rdbms_firebird',
DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc',
};
-plan skip_all => join (' ',
- 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}',
- 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},',
- '_USER and _PASS to run these tests.',
-
- "WARNING: This test drops and creates a table called 'event'",
-) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep;
-
-plan skip_all => ( 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('test_dt') )
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
+my @tdeps = values %$env2optdep;
+plan skip_all => 'Test needs ' . (join ' OR ', map
+ { "[ @{[ DBIx::Class::Optional::Dependencies->req_missing_for( $_ ) ]} ]" }
+ @tdeps
+) unless scalar grep
+ { DBIx::Class::Optional::Dependencies->req_ok_for( $_ ) }
+ @tdeps
+;
my $schema;
on_connect_call => [ 'datetime_setup' ],
});
- my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+ my $sg = scope_guard { cleanup($schema) };
eval { $schema->storage->dbh->do('DROP TABLE "event"') };
$schema->storage->dbh->do(<<'SQL');
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_informix );
+
use strict;
use warnings;
use Test::More;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
-use Scope::Guard ();
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
-. ' and ' .
-DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt')
- && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix');
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
-
-if (not $dsn) {
- plan skip_all => <<'EOF';
-Set $ENV{DBICTEST_INFORMIX_DSN} _USER and _PASS to run this test'.
-Warning: This test drops and creates a table called 'event'";
-EOF
-}
-
my $schema;
{
on_connect_call => [ 'datetime_setup' ],
});
- my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+ my $sg = scope_guard { cleanup($schema) };
eval { $schema->storage->dbh->do('DROP TABLE event') };
$schema->storage->dbh->do(<<'SQL');
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_msaccess_common );
+
use strict;
use warnings;
use Test::More;
-use Scope::Guard ();
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
+my @tdeps = qw( test_rdbms_msaccess_odbc test_rdbms_msaccess_ado );
+plan skip_all => 'Test needs ' . (join ' OR ', map
+ { "[ @{[ DBIx::Class::Optional::Dependencies->req_missing_for( $_ ) ]} ]" }
+ @tdeps
+) unless scalar grep
+ { DBIx::Class::Optional::Dependencies->req_ok_for( $_ ) }
+ @tdeps
+;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Test needs ' .
- (join ' and ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
- (join ' or ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'),
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado')))
- unless
- DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
- $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc')
- or
- $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado'))
- or (not $dsn || $dsn2);
-
-plan skip_all => <<'EOF' unless $dsn || $dsn2;
-Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.
-Warning: this test drops and creates the table 'track'.
-EOF
-
my @connect_info = (
[ $dsn, $user || '', $pass || '' ],
[ $dsn2, $user2 || '', $pass2 || '' ],
quote_names => 1,
});
- my $guard = Scope::Guard->new(sub { cleanup($schema) });
+ my $guard = scope_guard { cleanup($schema) };
try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') };
$schema->storage->dbh->do(<<"SQL");
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_mssql_common );
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
-use Scope::Guard ();
use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
+my @tdeps = qw( test_rdbms_mssql_odbc test_rdbms_mssql_sybase test_rdbms_mssql_ado );
+plan skip_all => 'Test needs ' . (join ' OR ', map
+ { "[ @{[ DBIx::Class::Optional::Dependencies->req_missing_for( $_ ) ]} ]" }
+ @tdeps
+) unless scalar grep
+ { DBIx::Class::Optional::Dependencies->req_ok_for( $_ ) }
+ @tdeps
+;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/};
my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Test needs ' .
- (join ' and ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
- (join ' or ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_odbc'),
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_sybase'),
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_ado')))
- unless
- DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
- $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_odbc')
- or
- $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_sybase')
- or
- $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_ado'))
- or (not $dsn || $dsn2 || $dsn3);
-
-if (not ($dsn || $dsn2 || $dsn3)) {
- plan skip_all =>
- 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} and/or '
- .'$ENV{DBICTEST_MSSQL_ADO_DSN} _USER and _PASS to run this test' .
- "\nWarning: This test drops and creates tables called 'event_small_dt' and"
- ." 'track'.";
-}
-
DBICTest::Schema->load_classes('EventSmallDT');
my @connect_info = (
}
}
- my $guard = Scope::Guard->new(sub{ cleanup($schema) });
+ my $guard = scope_guard { cleanup($schema) };
# $^W because DBD::ADO is a piece of crap
try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") };
--- /dev/null
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_oracle );
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+# DateTime::Format::Oracle needs this set
+$ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
+$ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF';
+$ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1';
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+# older oracles do not support a TIMESTAMP datatype
+my $timestamp_datatype = ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9
+ ? 'DATE'
+ : 'TIMESTAMP'
+;
+
+my $dbh = $schema->storage->dbh;
+
+#$dbh->do("alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SSXFF'");
+
+eval {
+ $dbh->do("DROP TABLE event");
+};
+$dbh->do(<<EOS);
+ CREATE TABLE event (
+ id number NOT NULL,
+ starts_at date NOT NULL,
+ created_on $timestamp_datatype NOT NULL,
+ varchar_date varchar(20),
+ varchar_datetime varchar(20),
+ skip_inflation date,
+ ts_without_tz date,
+ PRIMARY KEY (id)
+ )
+EOS
+
+# TODO is in effect for the rest of the tests
+local $TODO = 'FIXME - something odd is going on with Oracle < 9 datetime support'
+ if ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9;
+
+lives_ok {
+
+# insert a row to play with
+my $new = $schema->resultset('Event')->create({ id => 1, starts_at => '06-MAY-07', created_on => '2009-05-03 21:17:18.5' });
+is($new->id, 1, "insert sucessful");
+
+my $event = $schema->resultset('Event')->find( 1 );
+
+is( ref($event->starts_at), 'DateTime', "starts_at inflated ok");
+
+is( $event->starts_at->month, 5, "DateTime methods work on inflated column");
+
+is( ref($event->created_on), 'DateTime', "created_on inflated ok");
+
+is( $event->created_on->nanosecond, 500_000_000, "DateTime methods work with nanosecond precision");
+
+my $dt = DateTime->now();
+$event->starts_at($dt);
+$event->created_on($dt);
+$event->update;
+
+is( $event->starts_at->month, $dt->month, "deflate ok");
+is( int $event->created_on->nanosecond, int $dt->nanosecond, "deflate ok with nanosecond precision");
+
+# test datetime_setup
+
+$schema->storage->disconnect;
+
+delete $ENV{NLS_DATE_FORMAT};
+delete $ENV{NLS_TIMESTAMP_FORMAT};
+
+$schema->connection($dsn, $user, $pass, {
+ on_connect_call => 'datetime_setup'
+});
+
+$dt = DateTime->now();
+
+my $timestamp = $dt->clone;
+$timestamp->set_nanosecond( int 500_000_000 );
+
+$event = $schema->resultset('Event')->find( 1 );
+$event->update({ starts_at => $dt, created_on => $timestamp });
+
+$event = $schema->resultset('Event')->find(1);
+
+is( $event->starts_at, $dt, 'DateTime round-trip as DATE' );
+is( $event->created_on, $timestamp, 'DateTime round-trip as TIMESTAMP' );
+
+is( int $event->created_on->nanosecond, int 500_000_000,
+ 'TIMESTAMP nanoseconds survived' );
+
+} 'dateteime operations executed correctly';
+
+done_testing;
+
+# clean up our mess
+END {
+ if($schema && (my $dbh = $schema->storage->_dbh)) {
+ $dbh->do("DROP TABLE event");
+ }
+ undef $schema;
+}
+
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_sqlanywhere_common );
+
use strict;
use warnings;
use Test::More;
-use Scope::Guard ();
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
+my @tdeps = qw( test_rdbms_sqlanywhere test_rdbms_sqlanywhere_odbc );
+plan skip_all => 'Test needs ' . (join ' OR ', map
+ { "[ @{[ DBIx::Class::Optional::Dependencies->req_missing_for( $_ ) ]} ]" }
+ @tdeps
+) unless scalar grep
+ { DBIx::Class::Optional::Dependencies->req_ok_for( $_ ) }
+ @tdeps
+;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/};
my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SQLANYWHERE_ODBC_${_}" } qw/DSN USER PASS/};
-plan skip_all => 'Test needs ' .
- (join ' and ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
- (join ' or ', map { $_ ? $_ : () }
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere'),
- DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere_odbc')))
- unless
- DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
- $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere')
- or
- $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere_odbc'))
- or (not $dsn || $dsn2);
-
-if (not ($dsn || $dsn2)) {
- plan skip_all => <<'EOF';
-Set $ENV{DBICTEST_SQLANYWHERE_DSN} and/or $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN}
-_USER and _PASS to run this test'.
-Warning: This test drops and creates a table called 'event'";
-EOF
-}
-
my @info = (
[ $dsn, $user, $pass ],
[ $dsn2, $user2, $pass2 ],
on_connect_call => 'datetime_setup',
});
- my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+ my $sg = scope_guard { cleanup($schema) };
eval { $schema->storage->dbh->do('DROP TABLE event') };
$schema->storage->dbh->do(<<"SQL");
--- /dev/null
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_sqlite );
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+# Test offline parser determination (formerly t/inflate/datetime_determine_parser.t)
+{
+ my $schema = DBICTest->init_schema(
+ no_deploy => 1, # Deploying would cause an early rebless
+ );
+
+ my $storage = $schema->storage;
+
+ if ($ENV{DBICTEST_VIA_REPLICATED}) {
+ $storage = $storage->master;
+ }
+ else {
+ is(
+ ref $storage, 'DBIx::Class::Storage::DBI',
+ 'Starting with generic storage'
+ );
+ }
+
+ # Calling date_time_parser should cause the storage to be reblessed,
+ # so that we can pick up datetime_parser_type from subclasses
+ my $parser = $storage->datetime_parser();
+
+ is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser');
+ isa_ok($storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
+
+ ok(! $storage->connected, 'Not yet connected');
+}
+
+# so user's env doesn't screw us
+delete $ENV{DBIC_DT_SEARCH_OK};
+
+my $schema = DBICTest->init_schema();
+
+# inflation test
+my $event = $schema->resultset("Event")->find(1);
+
+isa_ok($event->starts_at, 'DateTime', 'DateTime returned');
+
+# klunky, but makes older Test::More installs happy
+my $starts = $event->starts_at;
+is("$starts", '2006-04-25T22:24:33', 'Correct date/time');
+
+my $dt_warn_re = qr/DateTime objects.+not supported properly/;
+
+my $row;
+
+{
+ local $ENV{DBIC_DT_SEARCH_OK} = 1;
+ local $SIG{__WARN__} = sub {
+ fail('Disabled warning still issued') if $_[0] =~ $dt_warn_re;
+ warn @_;
+ };
+ $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
+}
+
+warnings_exist {
+ $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
+} [$dt_warn_re],
+ 'using a DateTime object in ->search generates a warning';
+
+{
+ local $TODO = "This stuff won't work without a -dt operator of some sort"
+ unless eval { require DBIx::Class::SQLMaker::DateOps };
+
+ is(eval { $row->id }, 1, 'DT in search');
+
+ local $ENV{DBIC_DT_SEARCH_OK} = 1;
+
+ ok($row =
+ $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })
+ ->single);
+
+ is(eval { $row->id }, 1, 'DT in search with condition');
+}
+
+# create using DateTime
+my $created = $schema->resultset('Event')->create({
+ starts_at => DateTime->new(year=>2006, month=>6, day=>18),
+ created_on => DateTime->new(year=>2006, month=>6, day=>23)
+});
+my $created_start = $created->starts_at;
+
+isa_ok($created->starts_at, 'DateTime', 'DateTime returned');
+is("$created_start", '2006-06-18T00:00:00', 'Correct date/time');
+
+## timestamp field
+isa_ok($event->created_on, 'DateTime', 'DateTime returned');
+
+## varchar fields
+isa_ok($event->varchar_date, 'DateTime', 'DateTime returned');
+isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned');
+
+## skip inflation field
+isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column');
+
+# klunky, but makes older Test::More installs happy
+my $createo = $event->created_on;
+is("$createo", '2006-06-22T21:00:05', 'Correct date/time');
+
+my $created_cron = $created->created_on;
+
+isa_ok($created->created_on, 'DateTime', 'DateTime returned');
+is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time');
+
+## varchar field using inflate_date => 1
+my $varchar_date = $event->varchar_date;
+is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time');
+
+## varchar field using inflate_datetime => 1
+my $varchar_datetime = $event->varchar_datetime;
+is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
+
+## skip inflation field
+my $skip_inflation = $event->skip_inflation;
+is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
+
+# extra accessor tests with update_or_insert
+{
+ my $new = $schema->resultset("Track")->new( {
+ trackid => 100,
+ cd => 1,
+ title => 'Insert or Update',
+ last_updated_on => '1973-07-19 12:01:02'
+ } );
+ $new->update_or_insert;
+ ok($new->in_storage, 'update_or_insert insert ok');
+
+ # test in update mode
+ $new->title('Insert or Update - updated');
+ $new->update_or_insert;
+ is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok');
+
+ # test get_inflated_columns with objects
+ my $event = $schema->resultset('Event')->search->first;
+ my %edata = $event->get_inflated_columns;
+ is($edata{'id'}, $event->id, 'got id');
+ isa_ok($edata{'starts_at'}, 'DateTime', 'start_at is DateTime object');
+ isa_ok($edata{'created_on'}, 'DateTime', 'create_on DateTime object');
+ is($edata{'starts_at'}, $event->starts_at, 'got start date');
+ is($edata{'created_on'}, $event->created_on, 'got created date');
+
+ # get_inflated_columns w/relation and accessor alias
+ isa_ok($new->updated_date, 'DateTime', 'have inflated object via accessor');
+ my %tdata = $new->get_inflated_columns;
+ is($tdata{'trackid'}, 100, 'got id');
+ isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object');
+ is($tdata{'cd'}->id, 1, 'cd object is id 1');
+ is(
+ $tdata{'position'},
+ $schema->resultset ('Track')->search ({cd => 1})->count,
+ 'Ordered assigned proper position',
+ );
+ is($tdata{'title'}, 'Insert or Update - updated');
+ is($tdata{'last_updated_on'}, '1973-07-19T12:01:02');
+ isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column');
+}
+
+# create and update with literals
+{
+ my $d = {
+ created_on => \ '2001-09-11',
+ starts_at => \[ '?' => '2001-10-26' ],
+ };
+
+ my $ev = $schema->resultset('Event')->create($d);
+
+ for my $col (qw(created_on starts_at)) {
+ ok (ref $ev->$col, "literal untouched in $col");
+ is_deeply( $ev->$col, $d->{$col});
+ is_deeply( $ev->get_inflated_column($col), $d->{$col});
+ is_deeply( $ev->get_column($col), $d->{$col});
+ }
+
+ $ev->discard_changes;
+
+ is_deeply(
+ { $ev->get_dirty_columns },
+ {}
+ );
+
+ for my $col (qw(created_on starts_at)) {
+ isa_ok ($ev->$col, "DateTime", "$col properly inflated on retrieve");
+ }
+
+ for my $meth (qw(set_inflated_columns set_columns)) {
+
+ $ev->$meth({%$d});
+
+ is_deeply(
+ { $ev->get_dirty_columns },
+ $d,
+ "Expected dirty cols after setting literals via $meth",
+ );
+
+ $ev->update;
+
+ for my $col (qw(created_on starts_at)) {
+ ok (ref $ev->$col, "literal untouched in $col updated via $meth");
+ is_deeply( $ev->$col, $d->{$col});
+ is_deeply( $ev->get_inflated_column($col), $d->{$col});
+ is_deeply( $ev->get_column($col), $d->{$col});
+ }
+ }
+}
+
+done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_ase );
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
-use Scope::Guard ();
-use Try::Tiny;
-use DBIx::Class::Optional::Dependencies ();
+use DBIx::Class::_Util 'scope_guard';
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
-. ' and ' .
-DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt')
- && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase');
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
-if (not ($dsn && $user)) {
- plan skip_all =>
- 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' .
- "\nWarning: This test drops and creates a table called 'track' and " .
- "'event_small_dt'";
-}
-
DBICTest::Schema->load_classes('EventSmallDT');
my @storage_types = (
on_connect_call => 'datetime_setup',
});
- my $guard = Scope::Guard->new(sub { cleanup($schema) } );
+ my $guard = scope_guard { cleanup($schema) };
$schema->storage->ensure_connected;
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_mysql );
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Test::Warn;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
use DBICTest::Schema;
use DBIx::Class::_Util 'sigwarn_silencer';
-plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_mysql')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_mysql');
-
{
DBICTest::Schema->load_classes('EventTZ');
local $SIG{__WARN__} = sigwarn_silencer( qr/extra \=\> .+? has been deprecated/ );
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_pg );
+
use strict;
use warnings;
use Test::More;
use Test::Warn;
-use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg');
-
DBICTest::Schema->load_classes('EventTZPg');
+{
+ my $s = DBICTest::Schema->connect('dbi:Pg:whatever');
+
+ ok (!$s->storage->_dbh, 'definitely not connected');
+
+ # Check that datetime_parser returns correctly before we explicitly connect.
+ my $store = ref $s->storage;
+ is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
+
+ my $parser = $s->storage->datetime_parser;
+ is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
+
+ ok (!$s->storage->_dbh, 'still not connected');
+}
+
my $schema = DBICTest->init_schema();
+# this may generate warnings under certain CI flags, hence do it outside of
+# the warnings_are below
+my $dt = DateTime->new( year => 2000, time_zone => "America/Chicago" );
+
warnings_are {
my $event = $schema->resultset("EventTZPg")->find(1);
$event->update({created_on => '2009-01-15 17:00:00+00'});
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Warn;
-use Try::Tiny;
-use lib qw(t/lib);
-use DBICTest;
-
-# so user's env doesn't screw us
-delete $ENV{DBIC_DT_SEARCH_OK};
-
-my $schema = DBICTest->init_schema();
-
-plan skip_all => 'DT inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
-
-# inflation test
-my $event = $schema->resultset("Event")->find(1);
-
-isa_ok($event->starts_at, 'DateTime', 'DateTime returned');
-
-# klunky, but makes older Test::More installs happy
-my $starts = $event->starts_at;
-is("$starts", '2006-04-25T22:24:33', 'Correct date/time');
-
-my $dt_warn_re = qr/DateTime objects.+not supported properly/;
-
-my $row;
-
-{
- local $ENV{DBIC_DT_SEARCH_OK} = 1;
- local $SIG{__WARN__} = sub {
- fail('Disabled warning still issued') if $_[0] =~ $dt_warn_re;
- warn @_;
- };
- $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
-}
-
-warnings_exist {
- $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
-} [$dt_warn_re],
- 'using a DateTime object in ->search generates a warning';
-
-{
- local $TODO = "This stuff won't work without a -dt operator of some sort"
- unless eval { require DBIx::Class::SQLMaker::DateOps };
-
- is(eval { $row->id }, 1, 'DT in search');
-
- local $ENV{DBIC_DT_SEARCH_OK} = 1;
-
- ok($row =
- $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })
- ->single);
-
- is(eval { $row->id }, 1, 'DT in search with condition');
-}
-
-# create using DateTime
-my $created = $schema->resultset('Event')->create({
- starts_at => DateTime->new(year=>2006, month=>6, day=>18),
- created_on => DateTime->new(year=>2006, month=>6, day=>23)
-});
-my $created_start = $created->starts_at;
-
-isa_ok($created->starts_at, 'DateTime', 'DateTime returned');
-is("$created_start", '2006-06-18T00:00:00', 'Correct date/time');
-
-## timestamp field
-isa_ok($event->created_on, 'DateTime', 'DateTime returned');
-
-## varchar fields
-isa_ok($event->varchar_date, 'DateTime', 'DateTime returned');
-isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned');
-
-## skip inflation field
-isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column');
-
-# klunky, but makes older Test::More installs happy
-my $createo = $event->created_on;
-is("$createo", '2006-06-22T21:00:05', 'Correct date/time');
-
-my $created_cron = $created->created_on;
-
-isa_ok($created->created_on, 'DateTime', 'DateTime returned');
-is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time');
-
-## varchar field using inflate_date => 1
-my $varchar_date = $event->varchar_date;
-is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time');
-
-## varchar field using inflate_datetime => 1
-my $varchar_datetime = $event->varchar_datetime;
-is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
-
-## skip inflation field
-my $skip_inflation = $event->skip_inflation;
-is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
-
-done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
-
-my $schema = DBICTest->init_schema(
- no_deploy => 1, # Deploying would cause an early rebless
-);
-
-is(
- ref $schema->storage, 'DBIx::Class::Storage::DBI',
- 'Starting with generic storage'
-);
-
-# Calling date_time_parser should cause the storage to be reblessed,
-# so that we can pick up datetime_parser_type from subclasses
-
-my $parser = $schema->storage->datetime_parser();
-
-is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser');
-isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
-
-done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-use DBIx::Class::Optional::Dependencies ();
-use lib qw(t/lib);
-use DBICTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
-
-if (not ($dsn && $user && $pass)) {
- plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
- 'Warning: This test drops and creates a table called \'track\'';
-}
-
-# DateTime::Format::Oracle needs this set
-$ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
-$ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF';
-$ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1';
-$ENV{NLS_SORT} = "BINARY";
-$ENV{NLS_COMP} = "BINARY";
-
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-
-# older oracles do not support a TIMESTAMP datatype
-my $timestamp_datatype = ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9
- ? 'DATE'
- : 'TIMESTAMP'
-;
-
-# Need to redefine the last_updated_on column
-my $col_metadata = $schema->class('Track')->column_info('last_updated_on');
-$schema->class('Track')->add_column( 'last_updated_on' => {
- data_type => 'date' });
-$schema->class('Track')->add_column( 'last_updated_at' => {
- data_type => $timestamp_datatype });
-
-my $dbh = $schema->storage->dbh;
-
-#$dbh->do("alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SSXFF'");
-
-eval {
- $dbh->do("DROP TABLE track");
-};
-$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at $timestamp_datatype)");
-
-# TODO is in effect for the rest of the tests
-local $TODO = 'FIXME - something odd is going on with Oracle < 9 datetime support'
- if ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9;
-
-lives_ok {
-
-# insert a row to play with
-my $new = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1', last_updated_on => '06-MAY-07', last_updated_at => '2009-05-03 21:17:18.5' });
-is($new->trackid, 1, "insert sucessful");
-
-my $track = $schema->resultset('Track')->find( 1 );
-
-is( ref($track->last_updated_on), 'DateTime', "last_updated_on inflated ok");
-
-is( $track->last_updated_on->month, 5, "DateTime methods work on inflated column");
-
-#note '$track->last_updated_at => ', $track->last_updated_at;
-is( ref($track->last_updated_at), 'DateTime', "last_updated_at inflated ok");
-
-is( $track->last_updated_at->nanosecond, 500_000_000, "DateTime methods work with nanosecond precision");
-
-my $dt = DateTime->now();
-$track->last_updated_on($dt);
-$track->last_updated_at($dt);
-$track->update;
-
-is( $track->last_updated_on->month, $dt->month, "deflate ok");
-is( int $track->last_updated_at->nanosecond, int $dt->nanosecond, "deflate ok with nanosecond precision");
-
-# test datetime_setup
-
-$schema->storage->disconnect;
-
-delete $ENV{NLS_DATE_FORMAT};
-delete $ENV{NLS_TIMESTAMP_FORMAT};
-
-$schema->connection($dsn, $user, $pass, {
- on_connect_call => 'datetime_setup'
-});
-
-$dt = DateTime->now();
-
-my $timestamp = $dt->clone;
-$timestamp->set_nanosecond( int 500_000_000 );
-
-$track = $schema->resultset('Track')->find( 1 );
-$track->update({ last_updated_on => $dt, last_updated_at => $timestamp });
-
-$track = $schema->resultset('Track')->find(1);
-
-is( $track->last_updated_on, $dt, 'DateTime round-trip as DATE' );
-is( $track->last_updated_at, $timestamp, 'DateTime round-trip as TIMESTAMP' );
-
-is( int $track->last_updated_at->nanosecond, int 500_000_000,
- 'TIMESTAMP nanoseconds survived' );
-
-} 'dateteime operations executed correctly';
-
-done_testing;
-
-# clean up our mess
-END {
- if($schema && (my $dbh = $schema->storage->dbh)) {
- $dbh->do("DROP TABLE track");
- }
- undef $schema;
-}
-
use Test::More;
-use DBIx::Class::_Util 'modver_gt_or_eq';
+use DBIx::Class::_Util 'modver_gt_or_eq_and_lt';
use base();
BEGIN {
plan skip_all => 'base.pm 2.20 (only present in perl 5.19.7) is known to break this test'
- if modver_gt_or_eq(base => '2.19_01') and ! modver_gt_or_eq(base => '2.21');
+ if modver_gt_or_eq_and_lt( 'base', '2.19_01', '2.21' );
}
use Test::Exception;
}
}
-plan (skip_all => "No suitable serializer found") unless $selected;
-
DBICTest::Schema::Serialized->inflate_column( 'serialized',
{ inflate => $selected->{inflater},
deflate => $selected->{deflater},
},
);
-Class::C3->reinitialize;
+Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
my $struct_hash = {
a => 1,
);
#===== make sure make_column_dirty interacts reasonably with inflation
-$object = $rs->first;
+$object = $rs->search({}, { rows => 1 })->next;
$object->update ({serialized => { x => 'y'}});
$object->serialized->{x} = 'z'; # change state without notifying $object
+++ /dev/null
-package DBIC::DebugObj;
-
-use strict;
-use warnings;
-
-use Class::C3;
-
-use base qw/DBIx::Class::Storage::Statistics Exporter Class::Accessor::Fast/;
-
-__PACKAGE__->mk_accessors( qw/dbictest_sql_ref dbictest_bind_ref/ );
-
-
-=head2 new(PKG, SQL_REF, BIND_REF, ...)
-
-Creates a new instance that on subsequent queries will store
-the generated SQL to the scalar pointed to by SQL_REF and bind
-values to the array pointed to by BIND_REF.
-
-=cut
-
-sub new {
- my $pkg = shift;
- my $sql_ref = shift;
- my $bind_ref = shift;
-
- my $self = $pkg->SUPER::new(@_);
-
- $self->debugfh(undef);
-
- $self->dbictest_sql_ref($sql_ref);
- $self->dbictest_bind_ref($bind_ref || []);
-
- return $self;
-}
-
-sub query_start {
- my $self = shift;
-
- (${$self->dbictest_sql_ref}, @{$self->dbictest_bind_ref}) = @_;
-}
-
-sub query_end { }
-
-sub txn_begin { }
-
-sub txn_commit { }
-
-sub txn_rollback { }
-
-1;
+++ /dev/null
-package DBIC::SqlMakerTest;
-
-use strict;
-use warnings;
-
-use base qw/Exporter/;
-
-use Carp;
-use SQL::Abstract::Test;
-
-our @EXPORT = qw/
- is_same_sql_bind
- is_same_sql
- is_same_bind
-/;
-our @EXPORT_OK = qw/
- eq_sql
- eq_bind
- eq_sql_bind
-/;
-
-sub is_same_sql_bind {
- # unroll possible as_query arrayrefrefs
- my @args;
-
- for (1,2) {
- my $chunk = shift @_;
-
- if ( ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY' ) {
- my ($sql, @bind) = @$$chunk;
- push @args, ($sql, \@bind);
- }
- else {
- push @args, $chunk, shift @_;
- }
-
- }
-
- push @args, shift @_;
-
- croak "Unexpected argument(s) supplied to is_same_sql_bind: " . join ('; ', @_)
- if @_;
-
- @_ = @args;
- goto &SQL::Abstract::Test::is_same_sql_bind;
-}
-
-*is_same_sql = \&SQL::Abstract::Test::is_same_sql;
-*is_same_bind = \&SQL::Abstract::Test::is_same_bind;
-*eq_sql = \&SQL::Abstract::Test::eq_sql;
-*eq_bind = \&SQL::Abstract::Test::eq_bind;
-*eq_sql_bind = \&SQL::Abstract::Test::eq_sql_bind;
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
-
-=head1 SYNOPSIS
-
- use Test::More;
- use DBIC::SqlMakerTest;
-
- my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
- is_same_sql_bind(
- $sql, \@bind,
- $expected_sql, \@expected_bind,
- 'foo bar works'
- );
-
-=head1 DESCRIPTION
-
-Exports functions that can be used to compare generated SQL and bind values.
-
-This is a thin wrapper around L<SQL::Abstract::Test>, which makes it easier
-to compare as_query sql/bind arrayrefrefs directly.
-
-=head1 FUNCTIONS
-
-=head2 is_same_sql_bind
-
- is_same_sql_bind(
- $given_sql, \@given_bind,
- $expected_sql, \@expected_bind,
- $test_msg
- );
-
- is_same_sql_bind(
- $rs->as_query
- $expected_sql, \@expected_bind,
- $test_msg
- );
-
- is_same_sql_bind(
- \[$given_sql, @given_bind],
- $expected_sql, \@expected_bind,
- $test_msg
- );
-
-Compares given and expected pairs of C<($sql, \@bind)>, and calls
-L<Test::Builder/ok> on the result, with C<$test_msg> as message.
-
-=head2 is_same_sql
-
- is_same_sql(
- $given_sql,
- $expected_sql,
- $test_msg
- );
-
-Compares given and expected SQL statement, and calls L<Test::Builder/ok> on the
-result, with C<$test_msg> as message.
-
-=head2 is_same_bind
-
- is_same_bind(
- \@given_bind,
- \@expected_bind,
- $test_msg
- );
-
-Compares given and expected bind value lists, and calls L<Test::Builder/ok> on
-the result, with C<$test_msg> as message.
-
-=head2 eq_sql
-
- my $is_same = eq_sql($given_sql, $expected_sql);
-
-Compares the two SQL statements. Returns true IFF they are equivalent.
-
-=head2 eq_bind
-
- my $is_same = eq_sql(\@given_bind, \@expected_bind);
-
-Compares two lists of bind values. Returns true IFF their values are the same.
-
-=head2 eq_sql_bind
-
- my $is_same = eq_sql_bind(
- $given_sql, \@given_bind,
- $expected_sql, \@expected_bind
- );
-
-Compares the two SQL statements and the two lists of bind values. Returns true
-IFF they are equivalent and the bind values are the same.
-
-
-=head1 SEE ALSO
-
-L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
-
-=head1 AUTHOR
-
-Norbert Buchmuller, <norbi@nix.hu>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2008 by Norbert Buchmuller.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
use strict;
use warnings;
-# this noop trick initializes the STDOUT, so that the TAP::Harness
-# issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
-# keep spinning and scheduling jobs
-# This results in an overall much smoother job-queue drainage, since
-# the Harness blocks less
-# (ideally this needs to be addressed in T::H, but a quick patchjob
-# broke everything so tabling it for now)
-BEGIN {
- if ($INC{'Test/Builder.pm'}) {
- local $| = 1;
- print "#\n";
- }
-}
-
-use Module::Runtime 'module_notional_filename';
-BEGIN {
- for my $mod (qw( DBIC::SqlMakerTest SQL::Abstract )) {
- if ( $INC{ module_notional_filename($mod) } ) {
- # FIXME this does not seem to work in BEGIN - why?!
- #require Carp;
- #$Carp::Internal{ (__PACKAGE__) }++;
- #Carp::croak( __PACKAGE__ . " must be loaded before $mod" );
-
- my ($fr, @frame) = 1;
- while (@frame = caller($fr++)) {
- last if $frame[1] !~ m|^t/lib/DBICTest|;
- }
-
- die __PACKAGE__ . " must be loaded before $mod (or modules using $mod) at $frame[1] line $frame[2]\n";
- }
- }
-}
-
-use DBICTest::RunMode;
+use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
use DBICTest::Schema;
use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
-use DBICTest::Util 'local_umask';
+use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard );
use Carp;
use Path::Class::File ();
use File::Spec;
=head1 NAME
-DBICTest - Library to be used by DBIx::Class test scripts.
+DBICTest - Library to be used by DBIx::Class test scripts
=head1 SYNOPSIS
This module provides the basic utilities to write tests against
DBIx::Class.
+=head1 EXPORTS
+
+The module does not export anything by default, nor provides individual
+function exports in the conventional sense. Instead the following tags are
+recognized:
+
+=head2 :DiffSQL
+
+Same as C<use SQL::Abstract::Test
+qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
+L<is_same_sql|SQL::Abstract::Test/is_same_sql>
+L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
+
+=head2 :GlobalLock
+
+Some tests are very time sensitive and need to run on their own, without
+being disturbed by anything else grabbing CPU or disk IO. Hence why everything
+using C<DBICTest> grabs a shared lock, and the few tests that request a
+C<:GlobalLock> will ask for an exclusive one and block until they can get it.
+
=head1 METHODS
=head2 init_schema
This method removes the test SQLite database in t/var/DBIxClass.db
and then creates a new, empty database.
-This method will call deploy_schema() by default, unless the
-no_deploy flag is set.
+This method will call L<deploy_schema()|/deploy_schema> by default, unless the
+C<no_deploy> flag is set.
-Also, by default, this method will call populate_schema() by
-default, unless the no_deploy or no_populate flags are set.
+Also, by default, this method will call L<populate_schema()|/populate_schema>
+by default, unless the C<no_deploy> or C<no_populate> flags are set.
=cut
-# some tests are very time sensitive and need to run on their own, without
-# being disturbed by anything else grabbing CPU or disk IO. Hence why everything
-# using DBICTest grabs a shared lock, and the few tests that request a :GlobalLock
-# will ask for an exclusive one and block until they can get it
+# see L</:GlobalLock>
our ($global_lock_fh, $global_exclusive_lock);
sub import {
my $self = shift;
or die "Unable to open $lockpath: $!";
}
- for (@_) {
- if ($_ eq ':GlobalLock') {
- flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+ for my $exp (@_) {
+ if ($exp eq ':GlobalLock') {
+ DEBUG_TEST_CONCURRENCY_LOCKS > 1
+ and dbg "Waiting for EXCLUSIVE global lock...";
+
+ await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+
+ DEBUG_TEST_CONCURRENCY_LOCKS > 1
+ and dbg "Got EXCLUSIVE global lock";
+
$global_exclusive_lock = 1;
}
+ elsif ($exp eq ':DiffSQL') {
+ require SQL::Abstract::Test;
+ my $into = caller(0);
+ for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
+ no strict 'refs';
+ *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
+ }
+ }
else {
- croak "Unknown export $_ requested from $self";
+ croak "Unknown export $exp requested from $self";
}
}
unless ($global_exclusive_lock) {
- flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
+ DEBUG_TEST_CONCURRENCY_LOCKS > 1
+ and dbg "Waiting for SHARED global lock...";
+
+ await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
+
+ DEBUG_TEST_CONCURRENCY_LOCKS > 1
+ and dbg "Got SHARED global lock";
}
}
END {
+ # referencing here delays destruction even more
if ($global_lock_fh) {
- # delay destruction even more
+ DEBUG_TEST_CONCURRENCY_LOCKS > 1
+ and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
+ 1;
}
}
$SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
+my $need_global_cleanup;
sub _cleanup_dbfile {
# cleanup if this is us
if (
or
$ENV{DBICTEST_LOCK_HOLDER} == $$
) {
+ if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
+ $dbh->disconnect;
+ }
+
my $db_file = _sqlite_dbfilename();
unlink $_ for ($db_file, "${db_file}-journal");
}
# set a *DBI* disconnect callback, to make sure the physical SQLite
# file is still there (i.e. the test does not attempt to delete
# an open database, which fails on Win32)
- if (my $guard_cb = __mk_disconnect_guard($db_file)) {
+ if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
$dbh->{Callbacks} = {
connect => sub { $guard_cb->('connect') },
disconnect => sub { $guard_cb->('disconnect') },
- DESTROY => sub { $guard_cb->('DESTROY') },
+ DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
};
}
},
}
sub __mk_disconnect_guard {
- return if DBIx::Class::_ENV_::PEEPEENESS; # leaks handles, delaying DESTROY, can't work right
my $db_file = shift;
- return unless -f $db_file;
+
+ return if (
+ # this perl leaks handles, delaying DESTROY, can't work right
+ DBIx::Class::_ENV_::PEEPEENESS
+ or
+ ! -f $db_file
+ );
+
my $orig_inode = (stat($db_file))[1]
or return;
return;
}
elsif ($event eq 'disconnect') {
+ return unless $connected; # we already disconnected earlier
$connected = 0;
}
elsif ($event eq 'DESTROY' and ! $connected ) {
my $schema;
+ if (
+ $ENV{DBICTEST_VIA_REPLICATED} &&=
+ ( !$args{storage_type} && !defined $args{sqlite_use_file} )
+ ) {
+ $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
+ $args{sqlite_use_file} = 1;
+ }
+
+ my @dsn = $self->_database(%args);
+
if ($args{compose_connection}) {
+ $need_global_cleanup = 1;
$schema = DBICTest::Schema->compose_connection(
- 'DBICTest', $self->_database(%args)
+ 'DBICTest', @dsn
);
} else {
$schema = DBICTest::Schema->compose_namespace('DBICTest');
}
if ( !$args{no_connect} ) {
- $schema = $schema->connect($self->_database(%args));
+ $schema->connection(@dsn);
+
+ $schema->storage->connect_replicants(\@dsn)
+ if $ENV{DBICTEST_VIA_REPLICATED};
}
if ( !$args{no_deploy} ) {
}
END {
+ # Make sure we run after any cleanup in other END blocks
+ push @{ B::end_av()->object_2svref }, sub {
assert_empty_weakregistry($weak_registry, 'quiet');
+ };
}
=head2 deploy_schema
my $schema = shift;
my $args = shift || {};
- local $schema->storage->{debug}
- if ($ENV{TRAVIS}||'') eq 'true';
+ my $guard;
+ if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
+ $guard = scope_guard { $schema->storage->debug($old_dbg) };
+ $schema->storage->debug(0);
+ }
if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
$schema->deploy($args);
my $self = shift;
my $schema = shift;
- local $schema->storage->{debug}
- if ($ENV{TRAVIS}||'') eq 'true';
+ my $guard;
+ if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
+ $guard = scope_guard { $schema->storage->debug($old_dbg) };
+ $schema->storage->debug(0);
+ }
$schema->populate('Genre', [
[qw/genreid name/],
--- /dev/null
+package DBICTest::AntiPattern::NullObject;
+
+use warnings;
+use strict;
+
+use overload
+ 'bool' => sub { 0 },
+ '""' => sub { '' },
+ '0+' => sub { 0 },
+ fallback => 1
+;
+
+our $null = bless {}, __PACKAGE__;
+sub AUTOLOAD { $null }
+
+1;
--- /dev/null
+package DBICTest::AntiPattern::TrueZeroLen;
+
+use warnings;
+use strict;
+
+use overload
+ 'bool' => sub { 1 },
+ '""' => sub { '' },
+ fallback => 1
+;
+
+sub new { bless {}, shift }
+
+1;
--- /dev/null
+package #hide from pause
+ DBICTest::Base;
+
+use strict;
+use warnings;
+
+# must load before any DBIx::Class* namespaces
+use DBICTest::RunMode;
+
+sub _skip_namespace_frames { '^DBICTest' }
+
+1;
use strict;
use warnings;
-# must load before any DBIx::Class* namespaces
-use DBICTest::RunMode;
-
-use base 'DBIx::Class::Core';
+use base qw(DBICTest::Base DBIx::Class::Core);
#use base qw/DBIx::Class::Relationship::Cascade::Rekey DBIx::Class::Core/;
use strict;
use warnings;
-# must load before any DBIx::Class* namespaces
-use DBICTest::RunMode;
-
-use base 'DBIx::Class::ResultSet';
-__PACKAGE__->_skip_namespace_frames('^DBICTest');
+use base qw(DBICTest::Base DBIx::Class::ResultSet);
sub all_hri {
return [ shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' })->all ];
use strict;
use warnings;
+use base qw(DBICTest::Base DBIx::Class::Schema);
-# must load before any DBIx::Class* namespaces
-use DBICTest::RunMode;
+use Fcntl qw(:DEFAULT :seek :flock);
+use Time::HiRes 'sleep';
+use DBIx::Class::_Util 'scope_guard';
+use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
+use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
+use namespace::clean;
-use base 'DBIx::Class::Schema';
+if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) {
+ __PACKAGE__->exception_action( sub {
+
+ my ( $fr_num, $disarmed, $throw_exception_fr_num );
+ while( ! $disarmed and my @fr = caller(++$fr_num) ) {
+
+ $throw_exception_fr_num ||= (
+ $fr[3] eq 'DBIx::Class::ResultSource::throw_exception'
+ and
+ $fr_num
+ );
+
+ $disarmed = !! (
+ $fr[1] =~ / \A (?: \. [\/\\] )? x?t [\/\\] .+ \.t \z /x
+ and
+ (
+ $fr[3] =~ /\A (?:
+ Test::Exception::throws_ok
+ |
+ Test::Exception::dies_ok
+ |
+ Try::Tiny::try
+ |
+ \Q(eval)\E
+ ) \z /x
+ or
+ (
+ $fr[3] eq 'Test::Exception::lives_ok'
+ and
+ ( $::TODO or Test::Builder->new->in_todo )
+ )
+ )
+ );
+ }
+
+ Test::Builder->new->ok(0, join "\n",
+ 'Unexpected &exception_action invocation',
+ '',
+ ' You almost certainly used eval/try instead of dbic_internal_try()',
+ " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||())
+ ) unless $disarmed;
+
+ DBIx::Class::Exception->throw( $_[0] );
+ })
+}
+
+sub capture_executed_sql_bind {
+ my ($self, $cref) = @_;
+
+ $self->throw_exception("Expecting a coderef to run") unless ref $cref eq 'CODE';
+
+ require DBICTest::SQLTracerObj;
+
+ # hack around stupid, stupid API
+ no warnings 'redefine';
+ local *DBIx::Class::Storage::DBI::_format_for_trace = sub { $_[1] };
+ Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
+
+ # can not use local() due to an unknown number of storages
+ # (think replicated)
+ my $orig_states = { map
+ { $_ => $self->storage->$_ }
+ qw(debugcb debugobj debug)
+ };
+
+ my $sg = scope_guard {
+ $self->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states;
+ };
+
+ $self->storage->debugcb(undef);
+ $self->storage->debugobj( my $tracer_obj = DBICTest::SQLTracerObj->new );
+ $self->storage->debug(1);
+
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ $cref->();
+
+ return $tracer_obj->{sqlbinds} || [];
+}
+
+sub is_executed_querycount {
+ my ($self, $cref, $exp_counts, $msg) = @_;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $self->throw_exception("Expecting an hashref of counts or an integer representing total query count")
+ unless ref $exp_counts eq 'HASH' or (defined $exp_counts and ! ref $exp_counts);
+
+ my @got = map { $_->[0] } @{ $self->capture_executed_sql_bind($cref) };
+
+ return Test::More::is( @got, $exp_counts, $msg )
+ unless ref $exp_counts;
+
+ my $got_counts = { map { $_ => 0 } keys %$exp_counts };
+ $got_counts->{$_}++ for @got;
+
+ return Test::More::is_deeply(
+ $got_counts,
+ $exp_counts,
+ $msg,
+ );
+}
+
+sub is_executed_sql_bind {
+ my ($self, $cref, $sqlbinds, $msg) = @_;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $self->throw_exception("Expecting an arrayref of SQL/Bind pairs") unless ref $sqlbinds eq 'ARRAY';
+
+ my @expected = @$sqlbinds;
+
+ my @got = map { $_->[1] } @{ $self->capture_executed_sql_bind($cref) };
+
+
+ return Test::Builder->new->ok(1, $msg || "No queries executed while running $cref")
+ if !@got and !@expected;
+
+ require SQL::Abstract::Test;
+ my $ret = 1;
+ while (@expected or @got) {
+ my $left = shift @got;
+ my $right = shift @expected;
+
+ # allow the right side to "simplify" the entire shebang
+ if ($left and $right) {
+ $left = [ @$left ];
+ for my $i (1..$#$right) {
+ if (
+ ! ref $right->[$i]
+ and
+ ref $left->[$i] eq 'ARRAY'
+ and
+ @{$left->[$i]} == 2
+ ) {
+ $left->[$i] = $left->[$i][1]
+ }
+ }
+ }
+
+ $ret &= SQL::Abstract::Test::is_same_sql_bind(
+ \( $left || [] ),
+ \( $right || [] ),
+ $msg,
+ );
+ }
+
+ return $ret;
+}
+
+our $locker;
+END {
+ # we need the $locker to be referenced here for delayed destruction
+ if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}";
+ }
+}
+
+my $weak_registry = {};
+
+sub connection {
+ my $self = shift->next::method(@_);
+
+# MASSIVE FIXME
+# we can't really lock based on DSN, as we do not yet have a way to tell that e.g.
+# DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst
+# and
+# DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0
+# are the same server
+# hence we lock everything based on sqlt_type or just globally if not available
+# just pretend we are python you know? :)
+
+
+ # when we get a proper DSN resolution sanitize to produce a portable lockfile name
+ # this may look weird and unnecessary, but consider running tests from
+ # windows over a samba share >.>
+ #utf8::encode($dsn);
+ #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge;
+ #$dsn =~ s/^dbi/dbi/i;
+
+ # provide locking for physical (non-memory) DSNs, so that tests can
+ # safely run in parallel. While the harness (make -jN test) does set
+ # an envvar, we can not detect when a user invokes prove -jN. Hence
+ # perform the locking at all times, it shouldn't hurt.
+ # the lock fh *should* inherit across forks/subprocesses
+ if (
+ ! $DBICTest::global_exclusive_lock
+ and
+ ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ )
+ and
+ ref($_[0]) ne 'CODE'
+ and
+ ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
+ ) {
+
+ my $locktype;
+
+ {
+ # guard against infinite recursion
+ local $ENV{DBICTEST_LOCK_HOLDER} = -1;
+
+ # we need to work with a forced fresh clone so that we do not upset any state
+ # of the main $schema (some tests examine it quite closely)
+ local $SIG{__WARN__} = sub {};
+ local $@;
+
+ # this will either give us an undef $locktype or will determine things
+ # properly with a default ( possibly connecting in the process )
+ eval {
+ my $s = ref($self)->connect(@{$self->storage->connect_info})->storage;
+
+ $locktype = $s->sqlt_type || 'generic';
+
+ # in case sqlt_type did connect, doesn't matter if it fails or something
+ $s->disconnect;
+ };
+ }
+
+ # Never hold more than one lock. This solves the "lock in order" issues
+ # unrelated tests may have
+ # Also if there is no connection - there is no lock to be had
+ if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
+
+ # this will release whatever lock we may currently be holding
+ # which is fine since the type does not match as checked above
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and $locker
+ and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}";
+
+ undef $locker;
+
+ my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock");
+
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and dbg "Waiting for $locktype LOCK: $lockpath...";
+
+ my $lock_fh;
+ {
+ my $u = local_umask(0); # so that the file opens as 666, and any user can lock
+ sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
+ }
+
+ await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and dbg "Got $locktype LOCK: $lockpath";
+
+ # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
+ # if we do not do this we may end up trampling over some long-running END or somesuch
+ seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
+ my $old_pid;
+ if (
+ read ($lock_fh, $old_pid, 100)
+ and
+ ($old_pid) = $old_pid =~ /^(\d+)$/
+ ) {
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and dbg "Post-grab WAIT for $old_pid START: $lockpath";
+
+ for (1..50) {
+ kill (0, $old_pid) or last;
+ sleep 0.1;
+ }
+
+ DEBUG_TEST_CONCURRENCY_LOCKS
+ and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath";
+ }
+
+ truncate $lock_fh, 0;
+ seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
+ $lock_fh->autoflush(1);
+ print $lock_fh $$;
+
+ $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
+
+ $locker = {
+ type => $locktype,
+ fh => $lock_fh,
+ lock_name => "$lockpath",
+ };
+ }
+ }
+
+ if ($INC{'Test/Builder.pm'}) {
+ populate_weakregistry ( $weak_registry, $self->storage );
+
+ my $cur_connect_call = $self->storage->on_connect_call;
+
+ $self->storage->on_connect_call([
+ (ref $cur_connect_call eq 'ARRAY'
+ ? @$cur_connect_call
+ : ($cur_connect_call || ())
+ ),
+ [sub {
+ populate_weakregistry( $weak_registry, shift->_dbh )
+ }],
+ ]);
+ }
+
+ return $self;
+}
+
+sub clone {
+ my $self = shift->next::method(@_);
+ populate_weakregistry ( $weak_registry, $self )
+ if $INC{'Test/Builder.pm'};
+ $self;
+}
+
+END {
+ # Make sure we run after any cleanup in other END blocks
+ push @{ B::end_av()->object_2svref }, sub {
+ assert_empty_weakregistry($weak_registry, 'quiet');
+ };
+}
1;
die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n";
}
+
+ if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) {
+ my $ov = UNIVERSAL->can("VERSION");
+
+ require Carp;
+
+ no warnings 'redefine';
+ *UNIVERSAL::VERSION = sub {
+ Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' );
+ &$ov;
+ };
+ }
+
+ if (
+ $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION}
+ or
+ # keep it always on during CI
+ (
+ ($ENV{TRAVIS}||'') eq 'true'
+ and
+ ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
+ )
+ ) {
+ require Try::Tiny;
+ my $orig = \&Try::Tiny::try;
+
+ no warnings 'redefine';
+ *Try::Tiny::try = sub (&;@) {
+ my ($fr, $first_pkg) = 0;
+ while( $first_pkg = caller($fr++) ) {
+ last if $first_pkg !~ /^
+ __ANON__
+ |
+ \Q(eval)\E
+ $/x;
+ }
+
+ if ($first_pkg =~ /DBIx::Class/) {
+ require Test::Builder;
+ Test::Builder->new->ok(0,
+ 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead'
+ );
+ }
+
+ goto $orig;
+ };
+ }
}
use Path::Class qw/file dir/;
my $reason_dir_unusable;
my @parts = File::Spec->splitdir($dir);
- if (@parts == 2 and $parts[1] =~ /^ [ \\ \/ ]? $/x ) {
+ if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) {
$reason_dir_unusable =
'File::Spec->tmpdir returned a root directory instead of a designated '
. 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)';
}
sub is_smoker {
- return
- ( ($ENV{TRAVIS}||'') eq 'true' )
- ||
+ return (
( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} )
- ;
+ or
+ __PACKAGE__->is_ci
+ );
+}
+
+sub is_ci {
+ return (
+ ($ENV{TRAVIS}||'') eq 'true'
+ and
+ ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
+ )
}
sub is_plain {
- return (! __PACKAGE__->is_smoker && ! __PACKAGE__->is_author && ! $ENV{RELEASE_TESTING} )
+ return (
+ ! $ENV{RELEASE_TESTING}
+ and
+ ! $ENV{DBICTEST_RUN_ALL_TESTS}
+ and
+ ! __PACKAGE__->is_smoker
+ and
+ ! __PACKAGE__->is_author
+ )
}
# Try to determine the root of a checkout/untar if possible
--- /dev/null
+package # moar hide
+ DBICTest::SQLTracerObj;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Storage::Statistics';
+
+sub query_start {
+ my ($self, $sql, $bind) = @_;
+
+ my $op = ($sql =~ /^\s*(\S+)/)[0];
+
+ $sql =~ s/^ \s* \Q$op\E \s+ \[ .+? \]/$op/x
+ if $ENV{DBICTEST_VIA_REPLICATED};
+
+ push @{$self->{sqlbinds}}, [ $op, [ $sql, @{ $bind || [] } ] ];
+}
+
+# who the hell came up with this API >:(
+for my $txn (qw(begin rollback commit)) {
+ no strict 'refs';
+ *{"txn_$txn"} = sub { push @{$_[0]{sqlbinds}}, [ uc $txn => [ uc $txn ] ] };
+}
+
+sub svp_begin { push @{$_[0]{sqlbinds}}, [ SAVEPOINT => [ "SAVEPOINT $_[1]" ] ] }
+sub svp_release { push @{$_[0]{sqlbinds}}, [ RELEASE_SAVEPOINT => [ "RELEASE $_[1]" ] ] }
+sub svp_rollback { push @{$_[0]{sqlbinds}}, [ ROLLBACK_TO_SAVEPOINT => [ "ROLLBACK TO $_[1]" ] ] }
+
+1;
use base 'DBICTest::BaseSchema';
-use Fcntl qw/:DEFAULT :seek :flock/;
-use Time::HiRes 'sleep';
-use DBICTest::RunMode;
-use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
-use DBICTest::Util 'local_umask';
-use namespace::clean;
-
__PACKAGE__->mk_group_accessors(simple => 'custom_attr');
__PACKAGE__->load_classes(qw/
'CD_to_Producer',
'Dummy', # this is a real result class we remove in the hook below
),
- qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
+ qw/SelfRefAlias TreeLike TwoKeyTreeLike Event NoPrimaryKey/,
qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
qw/ForceForeign Encoded/,
);
$sqlt_schema->drop_table('dummy');
}
-
-our $locker;
-END {
- # we need the $locker to be referenced here for delayed destruction
- if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
- #warn "$$ $0 $locker->{type} LOCK RELEASED";
- }
-}
-
-my $weak_registry = {};
-
-sub connection {
- my $self = shift->next::method(@_);
-
-# MASSIVE FIXME
-# we can't really lock based on DSN, as we do not yet have a way to tell that e.g.
-# DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst
-# and
-# DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0
-# are the same server
-# hence we lock everything based on sqlt_type or just globally if not available
-# just pretend we are python you know? :)
-
-
- # when we get a proper DSN resolution sanitize to produce a portable lockfile name
- # this may look weird and unnecessary, but consider running tests from
- # windows over a samba share >.>
- #utf8::encode($dsn);
- #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge;
- #$dsn =~ s/^dbi/dbi/i;
-
- # provide locking for physical (non-memory) DSNs, so that tests can
- # safely run in parallel. While the harness (make -jN test) does set
- # an envvar, we can not detect when a user invokes prove -jN. Hence
- # perform the locking at all times, it shouldn't hurt.
- # the lock fh *should* inherit across forks/subprocesses
- #
- # File locking is hard. Really hard. By far the best lock implementation
- # I've seen is part of the guts of File::Temp. However it is sadly not
- # reusable. Since I am not aware of folks doing NFS parallel testing,
- # nor are we known to work on VMS, I am just going to punt this and
- # use the portable-ish flock() provided by perl itself. If this does
- # not work for you - patches more than welcome.
- if (
- ! $DBICTest::global_exclusive_lock
- and
- ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ )
- and
- ref($_[0]) ne 'CODE'
- and
- ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
- ) {
-
- my $locktype = do {
- # guard against infinite recursion
- local $ENV{DBICTEST_LOCK_HOLDER} = -1;
-
- # we need to connect a forced fresh clone so that we do not upset any state
- # of the main $schema (some tests examine it quite closely)
- local $@;
- my $storage = eval {
- my $st = ref($self)->connect(@{$self->storage->connect_info})->storage;
- $st->ensure_connected; # do connect here, to catch a possible throw
- $st;
- };
- $storage
- ? do {
- my $t = $storage->sqlt_type || 'generic';
- eval { $storage->disconnect };
- $t;
- }
- : undef
- ;
- };
-
- # Never hold more than one lock. This solves the "lock in order" issues
- # unrelated tests may have
- # Also if there is no connection - there is no lock to be had
- if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
-
- # this will release whatever lock we may currently be holding
- # which is fine since the type does not match as checked above
- undef $locker;
-
- my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock");
-
- #warn "$$ $0 $locktype GRABBING LOCK";
- my $lock_fh;
- {
- my $u = local_umask(0); # so that the file opens as 666, and any user can lock
- sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
- }
- flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
- #warn "$$ $0 $locktype LOCK GRABBED";
-
- # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
- # if we do not do this we may end up trampling over some long-running END or somesuch
- seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
- my $old_pid;
- if (
- read ($lock_fh, $old_pid, 100)
- and
- ($old_pid) = $old_pid =~ /^(\d+)$/
- ) {
- for (1..50) {
- kill (0, $old_pid) or last;
- sleep 0.1;
- }
- }
- #warn "$$ $0 $locktype POST GRAB WAIT";
-
- truncate $lock_fh, 0;
- seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
- $lock_fh->autoflush(1);
- print $lock_fh $$;
-
- $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
-
- $locker = {
- type => $locktype,
- fh => $lock_fh,
- lock_name => "$lockpath",
- };
- }
- }
-
- if ($INC{'Test/Builder.pm'}) {
- populate_weakregistry ( $weak_registry, $self->storage );
-
- my $cur_connect_call = $self->storage->on_connect_call;
-
- $self->storage->on_connect_call([
- (ref $cur_connect_call eq 'ARRAY'
- ? @$cur_connect_call
- : ($cur_connect_call || ())
- ),
- [sub {
- populate_weakregistry( $weak_registry, shift->_dbh )
- }],
- ]);
- }
-
- return $self;
-}
-
-sub clone {
- my $self = shift->next::method(@_);
- populate_weakregistry ( $weak_registry, $self )
- if $INC{'Test/Builder.pm'};
- $self;
-}
-
-END {
- assert_empty_weakregistry($weak_registry, 'quiet');
-}
-
1;
use warnings;
use strict;
-use base qw/DBICTest::BaseResult/;
-use Carp qw/confess/;
+use base 'DBICTest::BaseResult';
+use DBICTest::Util 'check_customcond_args';
__PACKAGE__->table('artist');
__PACKAGE__->source_info({
{ order_by => { -asc => 'year'} },
);
+__PACKAGE__->has_many(
+ cds_cref_cond => 'DBICTest::Schema::CD',
+ sub {
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
+ return (
+ { "$args->{foreign_alias}.artist" => { '=' => { -ident => "$args->{self_alias}.artistid"} },
+ },
+ $args->{self_result_object} && {
+ "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid, # keep old rowobj syntax as a test
+ }
+ );
+ },
+);
__PACKAGE__->has_many(
cds_80s => 'DBICTest::Schema::CD',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
- { "$args->{foreign_alias}.artist" => { '=' => { -ident => "$args->{self_alias}.artistid"} },
+ { "$args->{foreign_alias}.artist" => { '=' => \ "$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 },
}
);
__PACKAGE__->has_many(
cds_84 => 'DBICTest::Schema::CD',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
"$args->{foreign_alias}.year" => 1984,
},
- $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" => 1984,
}
);
__PACKAGE__->has_many(
cds_90s => 'DBICTest::Schema::CD',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
__PACKAGE__->has_many(
cds_without_genre => 'DBICTest::Schema::CD',
sub {
- my $args = shift;
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
return (
{
"$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
"$args->{foreign_alias}.genreid" => undef,
- }, $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}.genreid" => undef,
}
),
sub store_column {
my ($self, $name, $value) = @_;
- $value = 'X '.$value if ($name eq 'name' && $value && $value =~ /(X )?store_column test/);
+ $value = 'X '.$value if ($name eq 'name' && defined $value && $value =~ /(X )?store_column test/);
$self->next::method($name, $value);
}
use warnings;
use strict;
-use base qw/DBICTest::BaseResult/;
-use Carp qw/confess/;
+use base 'DBICTest::BaseResult';
+use DBICTest::Util 'check_customcond_args';
__PACKAGE__->table('cd_artwork');
__PACKAGE__->add_columns(
__PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id');
__PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist');
-# both to test manytomany with custom rel
-__PACKAGE__->many_to_many('artists_test_m2m', 'artwork_to_artist', 'artist_test_m2m');
-__PACKAGE__->many_to_many('artists_test_m2m_noopt', 'artwork_to_artist', 'artist_test_m2m_noopt');
+# both to test manytomany via double custom rel (deliberate misnamed accessor clash)
+__PACKAGE__->many_to_many('artist_limited_rank', 'artwork_to_artist_via_customcond', 'artist_limited_rank');
+__PACKAGE__->many_to_many('artist_limited_rank_opaque', 'artwork_to_artist_via_opaque_customcond', 'artist_limited_rank_opaque');
-# other test to manytomany
-__PACKAGE__->has_many('artwork_to_artist_test_m2m', 'DBICTest::Schema::Artwork_to_Artist',
+__PACKAGE__->has_many('artwork_to_artist_via_customcond', 'DBICTest::Schema::Artwork_to_Artist',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.artwork_cd_id" => { -ident => "$args->{self_alias}.cd_id" },
},
- $args->{self_rowobj} && {
- "$args->{foreign_alias}.artwork_cd_id" => $args->{self_rowobj}->cd_id,
+ $args->{self_result_object} && {
+ "$args->{foreign_alias}.artwork_cd_id" => $args->{self_result_object}->cd_id,
}
);
}
);
-__PACKAGE__->many_to_many('artists_test_m2m2', 'artwork_to_artist_test_m2m', 'artist');
+
+__PACKAGE__->has_many('artwork_to_artist_via_opaque_customcond', 'DBICTest::Schema::Artwork_to_Artist',
+ sub {
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
+ return (
+ { "$args->{foreign_alias}.artwork_cd_id" => { -ident => "$args->{self_alias}.cd_id" } },
+ );
+ }
+);
+
+__PACKAGE__->many_to_many('all_artists_via_opaque_customcond', 'artwork_to_artist_via_opaque_customcond', 'artist');
+
1;
use warnings;
use strict;
-use base qw/DBICTest::BaseResult/;
-use Carp qw/confess/;
+use base 'DBICTest::BaseResult';
+use DBICTest::Util 'check_customcond_args';
__PACKAGE__->table('artwork_to_artist');
__PACKAGE__->add_columns(
__PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id');
__PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id');
-__PACKAGE__->belongs_to('artist_test_m2m', 'DBICTest::Schema::Artist',
+__PACKAGE__->belongs_to('artist_limited_rank', 'DBICTest::Schema::Artist',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" },
"$args->{foreign_alias}.rank" => { '<' => 10 },
},
- $args->{self_rowobj} && {
- "$args->{foreign_alias}.artistid" => $args->{self_rowobj}->artist_id,
+ !$args->{self_result_object} ? () : {
+ "$args->{foreign_alias}.artistid" => $args->{self_result_object}->artist_id,
"$args->{foreign_alias}.rank" => { '<' => 10 },
- }
+ },
+ !$args->{foreign_values} ? () : {
+ "$args->{self_alias}.artist_id" => $args->{foreign_values}{artistid},
+ },
);
}
);
-__PACKAGE__->belongs_to('artist_test_m2m_noopt', 'DBICTest::Schema::Artist',
+__PACKAGE__->belongs_to('artist_limited_rank_opaque', 'DBICTest::Schema::Artist',
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" },
use warnings;
use strict;
-use base qw/DBICTest::BaseResult/;
+use base 'DBICTest::BaseResult';
+use DBICTest::Util 'check_customcond_args';
# this tests table name as scalar ref
# DO NOT REMOVE THE \
{ join_type => 'left'},
);
+__PACKAGE__->belongs_to( single_track_opaque => 'DBICTest::Schema::Track',
+ sub {
+ my $args = &check_customcond_args;
+ \ " $args->{foreign_alias}.trackid = $args->{self_alias}.single_track ";
+ },
+ { join_type => 'left'},
+);
+
# add a non-left single relationship for the complex prefetch tests
__PACKAGE__->belongs_to( existing_single_track => 'DBICTest::Schema::Track',
{ 'foreign.trackid' => 'self.single_track' },
cd_to_producer => 'DBICTest::Schema::CD_to_Producer' => 'cd'
);
+__PACKAGE__->has_many( twokeys => 'DBICTest::Schema::TwoKeys', 'cd' );
+
+
# the undef condition in this rel is *deliberate*
# tests oddball legacy syntax
__PACKAGE__->might_have(
'last_track',
'DBICTest::Schema::Track',
sub {
- my $args = shift;
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
return (
{
"$args->{foreign_alias}.trackid" => { '=' =>
use warnings;
use strict;
-use base qw/DBICTest::BaseResult/;
-use Carp qw/confess/;
+use base 'DBICTest::BaseResult';
+use DBICTest::Util 'check_customcond_args';
__PACKAGE__->load_components(qw{
+DBICTest::DeployComponent
__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, {
proxy => { cd_title => 'title' },
});
+# custom condition coderef
+__PACKAGE__->belongs_to( cd_cref_cond => 'DBICTest::Schema::CD',
+sub {
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
+ return (
+ {
+ "$args->{foreign_alias}.cdid" => { -ident => "$args->{self_alias}.cd" },
+ },
+
+ ! $args->{self_result_object} ? () : {
+ "$args->{foreign_alias}.cdid" => $args->{self_result_object}->get_column('cd')
+ },
+
+ ! $args->{foreign_values} ? () : {
+ "$args->{self_alias}.cd" => $args->{foreign_values}{cdid}
+ },
+ );
+}
+);
__PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd', {
proxy => 'year'
});
__PACKAGE__->has_many (
next_tracks => __PACKAGE__,
sub {
- my $args = shift;
-
# This is for test purposes only. A regular user does not
# need to sanity check the passed-in arguments, this is what
# the tests are for :)
- my @missing_args = grep { ! defined $args->{$_} }
- qw/self_alias foreign_alias self_resultsource foreign_relname/;
- confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
- if @missing_args;
+ my $args = &check_customcond_args;
return (
{ "$args->{foreign_alias}.cd" => { -ident => "$args->{self_alias}.cd" },
"$args->{foreign_alias}.position" => { '>' => { -ident => "$args->{self_alias}.position" } },
},
- $args->{self_rowobj} && {
- "$args->{foreign_alias}.cd" => $args->{self_rowobj}->get_column('cd'),
- "$args->{foreign_alias}.position" => { '>' => $args->{self_rowobj}->pos },
+ $args->{self_result_object} && {
+ "$args->{foreign_alias}.cd" => $args->{self_result_object}->get_column('cd'),
+ "$args->{foreign_alias}.position" => { '>' => $args->{self_result_object}->pos },
}
)
}
);
+__PACKAGE__->has_many (
+ deliberately_broken_all_cd_tracks => __PACKAGE__,
+ sub {
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my $args = &check_customcond_args;
+
+ return {
+ "$args->{foreign_alias}.cd" => "$args->{self_alias}.cd"
+ };
+ }
+);
+
our $hook_cb;
sub sqlt_deploy_hook {
{'foreign.artistid'=>'self.artist'},
);
-__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, add_fk_index => 0 } );
+__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, on_update => undef, on_delete => undef, add_fk_index => 0 } );
__PACKAGE__->has_many(
'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
# need to operate on the instance for things to work
__PACKAGE__->result_source_instance->view_definition( sprintf (
- 'SELECT %s FROM cd WHERE year = "2000"',
+ "SELECT %s FROM cd WHERE year = '2000'",
join (', ', __PACKAGE__->columns),
));
+++ /dev/null
-package DBICTest::Stats;
-use strict;
-use warnings;
-
-use base qw/DBIx::Class::Storage::Statistics/;
-
-sub txn_begin {
- my $self = shift;
-
- $self->{'TXN_BEGIN'}++;
- return $self->{'TXN_BEGIN'};
-}
-
-sub txn_rollback {
- my $self = shift;
-
- $self->{'TXN_ROLLBACK'}++;
- return $self->{'TXN_ROLLBACK'};
-}
-
-sub txn_commit {
- my $self = shift;
-
- $self->{'TXN_COMMIT'}++;
- return $self->{'TXN_COMMIT'};
-}
-
-sub svp_begin {
- my ($self, $name) = @_;
-
- $self->{'SVP_BEGIN'}++;
- return $self->{'SVP_BEGIN'};
-}
-
-sub svp_release {
- my ($self, $name) = @_;
-
- $self->{'SVP_RELEASE'}++;
- return $self->{'SVP_RELEASE'};
-}
-
-sub svp_rollback {
- my ($self, $name) = @_;
-
- $self->{'SVP_ROLLBACK'}++;
- return $self->{'SVP_ROLLBACK'};
-}
-
-sub query_start {
- my ($self, $string, @bind) = @_;
-
- $self->{'QUERY_START'}++;
- return $self->{'QUERY_START'};
-}
-
-sub query_end {
- my ($self, $string) = @_;
-
- $self->{'QUERY_END'}++;
- return $self->{'QUERY_START'};
-}
-
-1;
use warnings;
use strict;
+# this noop trick initializes the STDOUT, so that the TAP::Harness
+# issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
+# keep spinning and scheduling jobs
+# This results in an overall much smoother job-queue drainage, since
+# the Harness blocks less
+# (ideally this needs to be addressed in T::H, but a quick patchjob
+# broke everything so tabling it for now)
+BEGIN {
+ if ($INC{'Test/Builder.pm'}) {
+ local $| = 1;
+ print "#\n";
+ }
+}
+
+use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
+ ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
+ ||
+ 0
+;
+
use Config;
+use Carp qw(cluck confess croak);
+use Fcntl ':flock';
+use Scalar::Util qw(blessed refaddr);
+use DBIx::Class::_Util 'scope_guard';
use base 'Exporter';
-our @EXPORT_OK = qw/local_umask stacktrace/;
+our @EXPORT_OK = qw(
+ dbg stacktrace
+ local_umask
+ visit_namespaces
+ check_customcond_args
+ await_flock DEBUG_TEST_CONCURRENCY_LOCKS
+);
+
+if (DEBUG_TEST_CONCURRENCY_LOCKS) {
+ require DBI;
+ my $oc = DBI->can('connect');
+ no warnings 'redefine';
+ *DBI::connect = sub {
+ DBICTest::Util::dbg("Connecting to $_[1]");
+ goto $oc;
+ }
+}
+
+sub dbg ($) {
+ require Time::HiRes;
+ printf STDERR "\n%.06f %5s %-78s %s\n",
+ scalar Time::HiRes::time(),
+ $$,
+ $_[0],
+ $0,
+ ;
+}
+
+# File locking is hard. Really hard. By far the best lock implementation
+# I've seen is part of the guts of File::Temp. However it is sadly not
+# reusable. Since I am not aware of folks doing NFS parallel testing,
+# nor are we known to work on VMS, I am just going to punt this and
+# use the portable-ish flock() provided by perl itself. If this does
+# not work for you - patches more than welcome.
+#
+# This figure esentially means "how long can a single test hold a
+# resource before everyone else gives up waiting and aborts" or
+# in other words "how long does the longest test-group legitimally run?"
+my $lock_timeout_minutes = 15; # yes, that's long, I know
+my $wait_step_seconds = 0.25;
+
+sub await_flock ($$) {
+ my ($fh, $locktype) = @_;
+
+ my ($res, $tries);
+ while(
+ ! ( $res = flock( $fh, $locktype | LOCK_NB ) )
+ and
+ ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds
+ ) {
+ select( undef, undef, undef, $wait_step_seconds );
-sub local_umask {
+ # "say something" every 10 cycles to work around RT#108390
+ # jesus christ our tooling is such a crock of shit :(
+ print "#\n" if not $tries % 10;
+ }
+
+ return $res;
+}
+
+
+sub local_umask ($) {
return unless defined $Config{d_umask};
- die 'Calling local_umask() in void context makes no sense'
+ croak 'Calling local_umask() in void context makes no sense'
if ! defined wantarray;
- my $old_umask = umask(shift());
+ my $old_umask = umask($_[0]);
die "Setting umask failed: $!" unless defined $old_umask;
- return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
-}
-{
- package DBICTest::Util::UmaskGuard;
- sub DESTROY {
- local ($@, $!);
- eval { defined (umask ${$_[0]}) or die };
- warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
- if ($@ || $!);
- }
+ scope_guard(sub {
+ local ($@, $!, $?);
+
+ eval {
+ defined(umask $old_umask) or die "nope";
+ 1;
+ } or cluck (
+ "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
+ );
+ });
}
sub stacktrace {
$frame++;
my (@stack, @frame);
- while (@frame = caller($frame++)) {
+ while (@frame = CORE::caller($frame++)) {
push @stack, [@frame[3,1,2]];
}
return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
}
+sub check_customcond_args ($) {
+ my $args = shift;
+
+ confess "Expecting a hashref"
+ unless ref $args eq 'HASH';
+
+ for (qw(rel_name foreign_relname self_alias foreign_alias)) {
+ confess "Custom condition argument '$_' must be a plain string"
+ if length ref $args->{$_} or ! length $args->{$_};
+ }
+
+ confess "Current and legacy rel_name arguments do not match"
+ if $args->{rel_name} ne $args->{foreign_relname};
+
+ confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
+ unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
+
+ confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
+ unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
+
+ my $struct_cnt = 0;
+
+ if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
+ $struct_cnt++;
+ for (qw(self_result_object self_rowobj)) {
+ confess "Custom condition argument '$_' must be a result instance"
+ unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
+ }
+
+ confess "Current and legacy self_result_object arguments do not match"
+ if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
+ }
+
+ if (defined $args->{foreign_values}) {
+ $struct_cnt++;
+
+ confess "Custom condition argument 'foreign_values' must be a hash reference"
+ unless ref $args->{foreign_values} eq 'HASH';
+ }
+
+ confess "Data structures supplied on both ends of a relationship"
+ if $struct_cnt == 2;
+
+ $args;
+}
+
+sub visit_namespaces {
+ my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
+
+ my $visited_count = 1;
+
+ # A package and a namespace are subtly different things
+ $args->{package} ||= 'main';
+ $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
+ $args->{package} =~ s/^:://;
+
+ if ( $args->{action}->($args->{package}) ) {
+ my $ns =
+ ( ($args->{package} eq 'main') ? '' : $args->{package} )
+ .
+ '::'
+ ;
+
+ $visited_count += visit_namespaces( %$args, package => $_ ) for
+ grep
+ # this happens sometimes on %:: traversal
+ { $_ ne '::main' }
+ map
+ { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
+ do { no strict 'refs'; keys %$ns }
+ ;
+ }
+
+ return $visited_count;
+}
+
1;
use Carp;
use Scalar::Util qw(isweak weaken blessed reftype);
-use DBIx::Class::_Util qw(refcount hrefaddr);
+use DBIx::Class::_Util qw(refcount hrefaddr refdesc);
use DBIx::Class::Optional::Dependencies;
use Data::Dumper::Concise;
-use DBICTest::Util 'stacktrace';
+use DBICTest::Util qw( stacktrace visit_namespaces );
use constant {
- CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
- SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0,
+ CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
};
use base 'Exporter';
my $leaks_found = 0;
my %reg_of_regs;
-# so we don't trigger stringification
-sub _describe_ref {
- sprintf '%s%s(%s)',
- (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
- reftype $_[0],
- hrefaddr $_[0],
- ;
-}
-
sub populate_weakregistry {
my ($weak_registry, $target, $note) = @_;
for keys %$reg;
}
- # FIXME/INVESTIGATE - something fishy is going on with refs to plain
- # strings, perhaps something to do with the CoW work etc...
- return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR';
-
if (! defined $weak_registry->{$refaddr}{weakref}) {
$weak_registry->{$refaddr} = {
stacktrace => stacktrace(1),
weakref => $target,
};
- weaken( $weak_registry->{$refaddr}{weakref} );
- $refs_traced++;
+
+ # on perl < 5.8.3 sometimes a weaken can throw (can't find RT)
+ # so guard against that unlikely event
+ local $@;
+ eval { weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++ }
+ or delete $weak_registry->{$refaddr};
}
- my $desc = _describe_ref($target);
+ my $desc = refdesc $target;
$weak_registry->{$refaddr}{slot_names}{$desc} = 1;
if ($note) {
$note =~ s/\s*\Q$desc\E\s*//g;
$reg->{$new_addr} = $slot_info;
}
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
sub visit_refs {
elsif (CV_TRACING and $type eq 'CODE') {
$visited_cnt += visit_refs({ %$args, refs => [ map {
( !isweak($_) ) ? $_ : ()
- } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269
+ } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269
}
1;
- } or warn "Could not descend into @{[ _describe_ref($r) ]}: $@\n";
+ } or warn "Could not descend into @{[ refdesc $r ]}: $@\n";
}
$visited_cnt;
}
-sub visit_namespaces {
- my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
-
- my $visited = 1;
-
- $args->{package} ||= '::';
- $args->{package} = '::' if $args->{package} eq 'main';
-
- if ( $args->{action}->($args->{package}) ) {
-
- my $base = $args->{package};
- $base = '' if $base eq '::';
-
-
- $visited += visit_namespaces({ %$args, package => $_ }) for map
- { $_ =~ /(.+?)::$/ && "${base}::$1" }
- grep
- { $_ =~ /(?<!^main)::$/ }
- do { no strict 'refs'; keys %{ $base . '::'} }
- }
-
- return $visited;
-}
-
# compiles a list of addresses stored as globals (possibly even catching
# class data in the form of method closures), so we can skip them further on
sub symtable_referenced_addresses {
my $refs_per_pkg;
- my $dummy_addresslist;
-
my $seen_refs = {};
visit_namespaces(
action => sub {
no strict 'refs';
my $pkg = shift;
- $pkg = '' if $pkg eq '::';
- $pkg .= '::';
# the unless regex at the end skips some dangerous namespaces outright
# (but does not prevent descent)
$refs_per_pkg->{$pkg} += visit_refs (
seen_refs => $seen_refs,
- # FIXME FIXME FIXME
- # This is so damn odd - if we feed a constsub {1} (or in fact almost
- # anything other than the actionsub below, any scalarref will show
- # up as a leak, trapped by... something...
- # Ideally we should be able to const this to sub{1} and just return
- # $seen_refs (in fact it is identical to the dummy list at the end of
- # a run here). Alas this doesn't seem to work, so punt for now...
- action => sub { ++$dummy_addresslist->{ hrefaddr $_[0] } },
+ action => sub { 1 },
refs => [ map { my $sym = $_;
- # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
- ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
+ # *{"${pkg}::$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
+ ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}::$sym") : () ),
- ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
- ? ${"$pkg$sym"} : ()
+ ( defined *{"${pkg}::$sym"}{SCALAR} and length ref ${"${pkg}::$sym"} and ! isweak( ${"${pkg}::$sym"} ) )
+ ? ${"${pkg}::$sym"} : ()
,
( map {
- ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
- ? *{"$pkg$sym"}{$_}
+ ( defined *{"${pkg}::$sym"}{$_} and ! isweak(defined *{"${pkg}::$sym"}{$_}) )
+ ? *{"${pkg}::$sym"}{$_}
: ()
} qw(HASH ARRAY IO GLOB) ),
- } keys %$pkg ],
- ) unless $pkg =~ /^ :: (?:
+ } keys %{"${pkg}::"} ],
+ ) unless $pkg =~ /^ (?:
DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
- ) :: $/x;
+ ) $/x;
}
);
# in case we hooked bless any extra object creation will wreak
# havoc during the assert phase
local *CORE::GLOBAL::bless;
- *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) };
+ *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : CORE::caller() ) };
croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
}
- # the walk is very expensive - if we are $quiet (running in an END block)
- # we do not really need to be too thorough
- unless ($quiet) {
- delete $weak_registry->{$_} for keys %{ symtable_referenced_addresses() };
- }
-
+ # the symtable walk is very expensive
+ # if we are $quiet (running in an END block) we do not really need to be
+ # that thorough - can get by with only %Sub::Quote::QUOTED
+ delete $weak_registry->{$_} for $quiet
+ ? do {
+ my $refs = {};
+ visit_refs (
+ # only look at the closed over stuffs
+ refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ],
+ seen_refs => $refs,
+ action => sub { 1 },
+ );
+ keys %$refs;
+ }
+ : (
+ # full sumtable walk, starting from ::
+ keys %{ symtable_referenced_addresses() }
+ )
+ ;
for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
next if ! defined $weak_registry->{$addr}{weakref};
$leaks_found++ unless $tb->in_todo;
- $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
+ $tb->ok (0, "Expected garbage collection of $weak_registry->{$addr}{display_name}");
my $diag = do {
local $Data::Dumper::Maxdepth = 1;
# Devel::MAT::Dumper::dumpfh( $fh );
# close ($fh) or die $!;
#
-# use POSIX;
+# require POSIX;
# POSIX::_exit(1);
# }
}
if (! $quiet and !$leaks_found and ! $tb->in_todo) {
- $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
+ $tb->ok(1, sprintf "No leaks found at %s line %d", (CORE::caller())[1,2] );
}
}
END {
- if ($INC{'Test/Builder.pm'}) {
- my $tb = Test::Builder->new;
-
+ if (
+ $INC{'Test/Builder.pm'}
+ and
+ my $tb = do {
+ local $@;
+ my $t = eval { Test::Builder->new }
+ or warn "Test::Builder->new failed:\n$@\n";
+ $t;
+ }
+ ) {
# we check for test passage - a leak may be a part of a TODO
if ($leaks_found and !$tb->is_passing) {
else {
$tb->note("Auto checked $refs_traced references for leaks - none detected");
}
+
+ # also while we are here and not in plain runmode: make sure we never
+ # loaded any of the strictures XS bullshit (it's a leak in a sense)
+ unless (
+ $ENV{MOO_FATAL_WARNINGS}
+ or
+ # FIXME - SQLT loads strictures explicitly, /facedesk
+ # remove this INC check when 0fb58589 and 45287c815 are rectified
+ $INC{'SQL/Translator.pm'}
+ or
+ DBICTest::RunMode->is_plain
+ ) {
+ for (qw(indirect multidimensional bareword::filehandles)) {
+ exists $INC{ Module::Runtime::module_notional_filename($_) }
+ and
+ $tb->ok(0, "$_ load should not have been attempted!!!" )
+ }
+ }
}
}
+++ /dev/null
-package
- PrefetchBug;
-
-use strict;
-use warnings;
-
-use base qw/DBIx::Class::Schema/;
-
-__PACKAGE__->load_classes();
-
-1;
CREATE INDEX "fourkeys_to_twokeys_idx_t_artist_t_cd" ON "fourkeys_to_twokeys" ("t_artist", "t_cd");
CREATE VIEW "year2000cds" AS
- SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000";
+ SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = '2000';
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema( no_populate => 1 );
+
+my $t11 = $schema->resultset('Track')->find_or_create({
+ trackid => 1,
+ title => 'Track one cd one',
+ cd => {
+ year => 1,
+ title => 'CD one',
+ very_long_artist_relationship => {
+ name => 'Artist one',
+ }
+ }
+});
+
+my $t12 = $schema->resultset('Track')->find_or_create({
+ trackid => 2,
+ title => 'Track two cd one',
+ cd => {
+ title => 'CD one',
+ very_long_artist_relationship => {
+ name => 'Artist one',
+ }
+ }
+});
+
+# FIXME - MC should be smart enough to infer this on its own...
+$schema->resultset('Artist')->create({ name => 'Artist two' });
+
+my $t2 = $schema->resultset('Track')->find_or_create({
+ trackid => 3,
+ title => 'Track one cd one',
+ cd => {
+ year => 1,
+ title => 'CD one',
+ very_long_artist_relationship => {
+ name => 'Artist two',
+ }
+ }
+});
+
+is_deeply(
+ $schema->resultset('Artist')->search({}, {
+ prefetch => { cds => 'tracks' },
+ order_by => 'tracks.title',
+ })->all_hri,
+ [
+ { artistid => 1, charfield => undef, name => "Artist one", rank => 13, cds => [
+ { artist => 1, cdid => 1, genreid => undef, single_track => undef, title => "CD one", year => 1, tracks => [
+ { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track one cd one", trackid => 1 },
+ { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Track two cd one", trackid => 2 },
+ ]},
+ ]},
+ { artistid => 2, charfield => undef, name => "Artist two", rank => 13, cds => [
+ { artist => 2, cdid => 2, genreid => undef, single_track => undef, title => "CD one", year => 1, tracks => [
+ { cd => 2, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track one cd one", trackid => 3 },
+ ]},
+ ]},
+ ],
+ 'Expected state of database after several find_or_create rounds'
+);
+
+
+done_testing;
+
my $cd_title = "Test $type cd";
my $artist_names = [ map { "Artist via $type $_" } (1, 2) ];
- my $someartist = $artist_rs->next;
+ my $someartist = $artist_rs->search({}, { rows => 1 })->next;
lives_ok (sub {
my $cd = $schema->resultset('CD')->create ({
use Test::More;
use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-plan tests => 91;
-
my $schema = DBICTest->init_schema();
lives_ok ( sub {
$kurt_cobain->{cds} = [ $in_utero ];
+ warnings_exist {
+ $schema->resultset('Artist')->populate([ $kurt_cobain ]);
+ } qr/\QFast-path populate() with supplied related objects is not possible/;
+
- $schema->resultset('Artist')->populate([ $kurt_cobain ]); # %)
my $artist = $schema->resultset('Artist')->find({name => 'Kurt Cobain'});
is($artist->name, 'Kurt Cobain', 'Artist insertion ok');
is ($m2m_cd->first->producers->first->name, 'Cowboy Neal', 'Correct producer row created');
}, 'Test multi create over many_to_many');
-1;
+done_testing;
my $schema = DBICTest->init_schema();
my $cd = $schema->resultset('CD')->next;
+$cd->tracks->delete;
-lives_ok {
- $cd->tracks->delete;
+$schema->resultset('CD')->related_resultset('tracks')->delete;
- my @tracks = map
- { $cd->create_related('tracks', { title => "t_$_", position => $_ }) }
- (4,2,5,1,3)
- ;
+is $cd->tracks->count, 0, 'No tracks';
- for (@tracks) {
- $_->discard_changes;
- $_->delete;
- }
-} 'Creation/deletion of out-of order tracks successful';
+$cd->create_related('tracks', { title => "t_$_", position => $_ })
+ for (4,2,3,1,5);
+
+is $cd->tracks->count, 5, 'Created 5 tracks';
+
+# a txn should force the implicit pos reload, regardless of order
+$schema->txn_do(sub {
+ $cd->tracks->delete_all
+});
+
+is $cd->tracks->count, 0, 'Successfully deleted everything';
done_testing;
use Test::More;
use Test::Deep;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
-my $orig_debug = $schema->storage->debug;
my $cdrs = $schema->resultset('CD')->search({ 'me.artist' => { '!=', 2 }});
my $cd_data = { map {
$_->cdid => {
siblings => $cdrs->search ({ artist => $_->get_column('artist') })->count - 1,
- track_titles => [ map { $_->title } ($_->tracks->all) ],
+ track_titles => [ sort $_->tracks->get_column('title')->all ],
},
} ( $cdrs->all ) };
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
(SELECT COUNT( * )
FROM cd siblings
- WHERE siblings.artist = me.artist
+ WHERE me.artist != ?
+ AND siblings.artist = me.artist
AND siblings.cdid != me.cdid
AND siblings.cdid != ?
- AND me.artist != ?
),
tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at
FROM cd me
[
# subselect
- [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
- => 23414 ],
-
[ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
=> 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
# outher WHERE
[ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
=> 2 ],
'Expected SQL on correlated realiased subquery'
);
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++; });
-$schema->storage->debug(1);
-
-cmp_deeply (
- { map
- { $_->cdid => {
- track_titles => [ map { $_->title } ($_->tracks->all) ],
- siblings => $_->get_column ('sibling_count'),
- } }
- $c_rs->all
- },
- $cd_data,
- 'Proper information retrieved from correlated subquery'
-);
-
-is ($queries, 1, 'Only 1 query fired to retrieve everything');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugcb(undef);
+$schema->is_executed_querycount( sub {
+ cmp_deeply (
+ { map
+ { $_->cdid => {
+ track_titles => [ sort map { $_->title } ($_->tracks->all) ],
+ siblings => $_->get_column ('sibling_count'),
+ } }
+ $c_rs->all
+ },
+ $cd_data,
+ 'Proper information retrieved from correlated subquery'
+ );
+}, 1, 'Only 1 query fired to retrieve everything');
# now add an unbalanced select/as pair
$c_rs = $c_rs->search ({}, {
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
(SELECT COUNT( * )
FROM cd siblings
- WHERE siblings.artist = me.artist
+ WHERE me.artist != ?
+ AND siblings.artist = me.artist
AND siblings.cdid != me.cdid
AND siblings.cdid != ?
- AND me.artist != ?
),
(SELECT MIN( year ), MAX( year )
FROM cd siblings
- WHERE siblings.artist = me.artist
- AND me.artist != ?
+ WHERE me.artist != ?
+ AND siblings.artist = me.artist
),
tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at
FROM cd me
[
# first subselect
- [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
- => 23414 ],
-
[ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
=> 2 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
# second subselect
[ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
=> 2 ],
'Expected SQL on correlated realiased subquery'
);
+$schema->storage->disconnect;
+
# test for subselect identifier leakage
# NOTE - the hodge-podge mix of literal and regular identifuers is *deliberate*
for my $quote_names (0,1) {
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan tests => 23;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
{ prefetch => ['tracks', 'artist'] },
);
-
is($cd_rs->count, 5, 'CDs with tracks count');
is($cd_rs->search_related('tracks')->count, 15, 'Tracks associated with CDs count (before SELECT()ing)');
=> 4 ] ],
);
-
{
local $TODO = "Chaining with prefetch is fundamentally broken";
+ $schema->is_executed_querycount( sub {
- my $queries;
- $schema->storage->debugcb ( sub { $queries++ } );
- $schema->storage->debug (1);
-
- my $cds = $cd2->search_related ('artist', {}, { prefetch => { cds => 'tracks' }, join => 'twokeys' })
+ my $cds = $cd2->search_related ('artist', {}, { prefetch => { cds => 'tracks' }, join => 'twokeys' })
->search_related ('cds');
- my $tracks = $cds->search_related ('tracks');
-
- is($tracks->count, 2, "2 Tracks counted on cd via artist via one of the cds");
- is(scalar($tracks->all), 2, "2 Tracks prefetched on cd via artist via one of the cds");
- is($tracks->count, 2, "Cached 2 Tracks counted on cd via artist via one of the cds");
+ my $tracks = $cds->search_related ('tracks');
- is($cds->count, 2, "2 CDs counted on artist via one of the cds");
- is(scalar($cds->all), 2, "2 CDs prefetched on artist via one of the cds");
- is($cds->count, 2, "Cached 2 CDs counted on artist via one of the cds");
+ is($tracks->count, 2, "2 Tracks counted on cd via artist via one of the cds");
+ is(scalar($tracks->all), 2, "2 Tracks prefetched on cd via artist via one of the cds");
+ is($tracks->count, 2, "Cached 2 Tracks counted on cd via artist via one of the cds");
- is ($queries, 3, '2 counts + 1 prefetch?');
+ is($cds->count, 2, "2 CDs counted on artist via one of the cds");
+ is(scalar($cds->all), 2, "2 CDs prefetched on artist via one of the cds");
+ is($cds->count, 2, "Cached 2 CDs counted on artist via one of the cds");
+ }, 3, '2 counts + 1 prefetch?' );
}
+
+done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
},
});
-my $orig_debug = $schema->storage->debug;
-
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++; });
-$schema->storage->debug(1);
-
-my $cd = $schema->resultset('CD')->search( {}, { prefetch => 'artist' })->next;
-
-cmp_deeply
- { $cd->get_columns },
- { artist => 0, cdid => 0, genreid => 0, single_track => 0, title => '', year => 0 },
- 'Expected CD columns present',
-;
-
-cmp_deeply
- { $cd->artist->get_columns },
- { artistid => 0, charfield => 0, name => "", rank => 0 },
- 'Expected Artist columns present',
-;
-
-is $queries, 1, 'Only one query fired - prefetch worked';
-
-$schema->storage->debugcb(undef);
-$schema->storage->debug($orig_debug);
+$schema->is_executed_querycount( sub {
+ my $cd = $schema->resultset('CD')->search( {}, { prefetch => 'artist' })->next;
+
+ cmp_deeply
+ { $cd->get_columns },
+ { artist => 0, cdid => 0, genreid => 0, single_track => 0, title => '', year => 0 },
+ 'Expected CD columns present',
+ ;
+
+ cmp_deeply
+ { $cd->artist->get_columns },
+ { artistid => 0, charfield => 0, name => "", rank => 0 },
+ 'Expected Artist columns present',
+ ;
+}, 1, 'Only one query fired - prefetch worked' );
done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype;
my $schema = DBICTest->init_schema();
-my $sdebug = $schema->storage->debug;
my $cd_rs = $schema->resultset('CD')->search (
{ 'tracks.cd' => { '!=', undef } },
is ($_->tracks->count, 3, '3 tracks for CD' . $_->id );
}
+my @cdids = sort $cd_rs->get_column ('cdid')->all;
+
# Test a belongs_to prefetch of a has_many
{
my $track_rs = $schema->resultset ('Track')->search (
- { 'me.cd' => { -in => [ $cd_rs->get_column ('cdid')->all ] } },
+ { 'me.cd' => { -in => \@cdids } },
{
select => [
'me.cd',
is($track_rs->count, 5, 'Prefetched count with groupby');
is($track_rs->all, 5, 'Prefetched objects with groupby');
- {
- my $query_cnt = 0;
- $schema->storage->debugcb ( sub { $query_cnt++ } );
- $schema->storage->debug (1);
-
+ $schema->is_executed_querycount( sub {
while (my $collapsed_track = $track_rs->next) {
my $cdid = $collapsed_track->get_column('cd');
is($collapsed_track->get_column('track_count'), 3, "Correct count of tracks for CD $cdid" );
ok($collapsed_track->cd->title, "Prefetched title for CD $cdid" );
}
-
- is ($query_cnt, 1, 'Single query on prefetched titles');
- $schema->storage->debugcb (undef);
- $schema->storage->debug ($sdebug);
- }
+ }, 1, 'Single query on prefetched titles');
# Test sql by hand, as the sqlite db will simply paper over
# improper group/select combinations
me
)',
[ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
- => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
+ => $_ ] } @cdids ],
'count() query generated expected SQL',
);
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
)',
[ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
- => $_ ] } ( ($cd_rs->get_column ('cdid')->all) x 2 ) ],
+ => $_ ] } (@cdids) x 2 ],
'next() query generated expected SQL',
);
my ($top_cd) = $most_tracks_rs->all;
is ($top_cd->id, 2, 'Correct cd fetched on top'); # 2 because of the slice(1,1) earlier
- my $query_cnt = 0;
- $schema->storage->debugcb ( sub { $query_cnt++ } );
- $schema->storage->debug (1);
-
- is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly');
- is ($top_cd->tracks->count, 4, 'Count of prefetched tracks rs still correct');
- is ($top_cd->tracks->all, 4, 'Number of prefetched track objects still correct');
- is (
- $top_cd->liner_notes->notes,
- 'Buy Whiskey!',
- 'Correct liner pre-fetched with top cd',
- );
-
- is ($query_cnt, 0, 'No queries executed during prefetched data access');
- $schema->storage->debugcb (undef);
- $schema->storage->debug ($sdebug);
+ $schema->is_executed_querycount( sub {
+ is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly');
+ is ($top_cd->tracks->count, 4, 'Count of prefetched tracks rs still correct');
+ is ($top_cd->tracks->all, 4, 'Number of prefetched track objects still correct');
+ is (
+ $top_cd->liner_notes->notes,
+ 'Buy Whiskey!',
+ 'Correct liner pre-fetched with top cd',
+ );
+ }, 0, 'No queries executed during prefetched data access');
}
{
my ($top_cd) = $most_tracks_rs->all;
is ($top_cd->id, 2, 'Correct cd fetched on top'); # 2 because of the slice(1,1) earlier
- my $query_cnt = 0;
- $schema->storage->debugcb ( sub { $query_cnt++ } );
- $schema->storage->debug (1);
-
- is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly');
- is (
- $top_cd->liner_notes->notes,
- 'Buy Whiskey!',
- 'Correct liner pre-fetched with top cd',
- );
-
- is ($query_cnt, 0, 'No queries executed during prefetched data access');
- $schema->storage->debugcb (undef);
- $schema->storage->debug ($sdebug);
+ $schema->is_executed_querycount( sub {
+ is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly');
+ is (
+ $top_cd->liner_notes->notes,
+ 'Buy Whiskey!',
+ 'Correct liner pre-fetched with top cd',
+ );
+ }, 0, 'No queries executed during prefetched data access');
}
# RT 47779, test group_by as a scalar ref
{
my $track_rs = $schema->resultset ('Track')->search (
- { 'me.cd' => { -in => [ $cd_rs->get_column ('cdid')->all ] } },
+ { 'me.cd' => { -in => \@cdids } },
{
select => [
'me.cd',
me
)',
[ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
- => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
+ => $_ ] } (@cdids) ],
'count() query generated expected SQL',
);
}
use Test::Deep;
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
for @lines;
}
-{
- my $queries = 0;
- $schema->storage->debugcb(sub { $queries++ });
- my $orig_debug = $schema->storage->debug;
- $schema->storage->debug (1);
-
+$schema->is_executed_querycount( sub {
for my $use_next (0, 1) {
my @random_cds;
+ my $rs_r = $rs_random;
if ($use_next) {
warnings_exist {
- while (my $o = $rs_random->next) {
+ while (my $o = $rs_r->next) {
push @random_cds, $o;
}
} qr/performed an eager cursor slurp underneath/,
'Warned on auto-eager cursor';
}
else {
- @random_cds = $rs_random->all;
+ @random_cds = $rs_r->all;
}
is (@random_cds, 6, 'object count matches');
}
}
}
-
- $schema->storage->debugcb(undef);
- $schema->storage->debug($orig_debug);
- is ($queries, 2, "Only two queries for two prefetch calls total");
-}
+}, 2, "Only two queries for two prefetch calls total");
# can't cmp_deeply a random set - need *some* order
my $ord_rs = $rs->search({}, {
use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-my $sdebug = $schema->storage->debug;
#( 1 -> M + M )
my $cd_rs = $schema->resultset('CD')->search( { 'me.title' => 'Forkful of bees' } );
my $tracks_rs = $cd_rs->first->tracks;
my $tracks_count = $tracks_rs->count;
-my ( $pr_tracks_rs, $pr_tracks_count );
+$schema->is_executed_querycount( sub {
+ my $pcr = $pr_cd_rs;
+ my $pr_tracks_rs;
-my $queries = 0;
-$schema->storage->debugcb( sub { $queries++ } );
-$schema->storage->debug(1);
+ warnings_exist {
+ $pr_tracks_rs = $pcr->first->tracks;
+ } [], 'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)' ;
-my $o_mm_warn;
-{
- local $SIG{__WARN__} = sub { $o_mm_warn = shift };
- $pr_tracks_rs = $pr_cd_rs->first->tracks;
-};
-$pr_tracks_count = $pr_tracks_rs->count;
+ is( $pr_tracks_rs->count, $tracks_count,
+ 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)'
+ );
-ok( !$o_mm_warn,
-'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)'
-);
+ is( $pr_tracks_rs->all, $tracks_count,
+ 'equal amount of objects returned with and without prefetch over several same level has_many\'s (1 -> M + M)'
+ );
-is( $queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' );
-$schema->storage->debugcb(undef);
-$schema->storage->debug($sdebug);
+}, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' );
-is( $pr_tracks_count, $tracks_count,
-'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)'
-);
-is( $pr_tracks_rs->all, $tracks_rs->all,
-'equal amount of objects returned with and without prefetch over several same level has_many\'s (1 -> M + M)'
-);
#( M -> 1 -> M + M )
my $note_rs =
my $tags_rs = $note_rs->first->cd->tags;
my $tags_count = $tags_rs->count;
-my ( $pr_tags_rs, $pr_tags_count );
-
-$queries = 0;
-$schema->storage->debugcb( sub { $queries++ } );
-$schema->storage->debug(1);
-
-my $m_o_mm_warn;
-{
- local $SIG{__WARN__} = sub { $m_o_mm_warn = shift };
- $pr_tags_rs = $pr_note_rs->first->cd->tags;
-};
-$pr_tags_count = $pr_tags_rs->count;
-
-ok( !$m_o_mm_warn,
-'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)'
-);
-
-is( $queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' );
-$schema->storage->debugcb(undef);
-$schema->storage->debug($sdebug);
-
-is( $pr_tags_count, $tags_count,
-'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)'
-);
-is( $pr_tags_rs->all, $tags_rs->all,
-'equal amount of objects with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)'
-);
+$schema->is_executed_querycount( sub {
+ my $pnr = $pr_note_rs;
+ my $pr_tags_rs;
+
+ warnings_exist {
+ $pr_tags_rs = $pnr->first->cd->tags;
+ } [], 'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)';
+
+ is( $pr_tags_rs->count, $tags_count,
+ 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)'
+ );
+ is( $pr_tags_rs->all, $tags_count,
+ 'equal amount of objects with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)'
+ );
+
+}, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' );
+
done_testing;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
my $schema = DBICTest->init_schema();
cmp_deeply( $art_rs_prefetch->next, $artist_with_extras );
+for my $order (
+ [ [qw( cds.cdid tracks.position )] ],
+
+ [ [qw( artistid tracks.cd tracks.position )],
+ 'we need to proxy the knowledge from the collapser that tracks.cd is a stable sorter for CDs' ],
+) {
+
+ my $cds_rs_prefetch = $art_rs->related_resultset('cds')->search({}, {
+ order_by => [ $order->[0], qw(producer.name tracks_2.position) ],
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ prefetch => [
+ { tracks => { cd_single => 'tracks' } },
+ { cd_to_producer => 'producer' },
+ ],
+ });
+
+ local $SIG{__WARN__} = sigwarn_silencer(qr/Unable to properly collapse has_many results/) if $order->[1];
+
+ cmp_deeply( $cds_rs_prefetch->next, $artist_with_extras->{cds}[0], '1st cd structure matches' );
+ cmp_deeply( $cds_rs_prefetch->next, $artist_with_extras->{cds}[1], '2nd cd structure matches' );
+
+ # INTERNALS! (a.k.a boars, gore and whores) DO NOT CARGOCULT!!!
+ local $TODO = $order->[1] if $order->[1];
+ ok( $cds_rs_prefetch->_resolved_attrs->{_ordered_for_collapse}, 'ordered_for_collapse detected properly' );
+}
+
+
done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($ROWS, $OFFSET) = (
is ($artist->cds->count, 3, 'Correct number of CDs');
is ($artist->cds->search_related ('genre')->count, 1, 'Only one of the cds has a genre');
-my $queries = 0;
-my $orig_cb = $schema->storage->debugcb;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $pref = $schema->resultset ('Artist')
+$schema->is_executed_querycount( sub {
+ my $pref = $schema->resultset ('Artist')
->search ({ 'me.artistid' => $artist->id }, { prefetch => { cds => 'genre' } })
->next;
-is ($pref->cds->count, 3, 'Correct number of CDs prefetched');
-is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre');
+ is ($pref->cds->count, 3, 'Correct number of CDs prefetched');
+ is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre');
-is ($queries, 1, 'All happened within one query only');
-$schema->storage->debugcb($orig_cb);
-$schema->storage->debug(0);
+}, 1, 'All happened within one query only');
done_testing;
);
# this still should emit no queries:
-{
- my $queries = 0;
- my $orig_debug = $schema->storage->debug;
- $schema->storage->debugcb(sub { $queries++; });
- $schema->storage->debug(1);
+$schema->is_executed_querycount( sub {
my $cds = $art->cds;
is (
);
}
- $schema->storage->debug($orig_debug);
- $schema->storage->debugcb(undef);
-
- is ($queries, 0, 'No queries on prefetched operations');
-}
+}, 0, 'No queries on prefetched operations');
done_testing;
use DBICTest;
my $schema = DBICTest->init_schema();
-my $orig_debug = $schema->storage->debug;
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++; });
-$schema->storage->debug(1);
-
-my $search = { 'artist.name' => 'Caterwauler McCrae' };
-my $attr = { prefetch => [ qw/artist liner_notes/ ],
+my $rs;
+$schema->is_executed_querycount( sub {
+ my $search = { 'artist.name' => 'Caterwauler McCrae' };
+ my $attr = { prefetch => [ qw/artist liner_notes/ ],
order_by => 'me.cdid' };
-my $rs = $schema->resultset("CD")->search($search, $attr);
-my @cd = $rs->all;
-
-is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
+ $rs = $schema->resultset("CD")->search($search, $attr);
+ my @cd = $rs->all;
-ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
+ is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
-is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
+ ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
-is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
+ is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
-is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
+ is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
-is($queries, 1, 'prefetch ran only 1 select statement');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
+ is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
+}, 1, 'prefetch ran only 1 select statement');
# test for partial prefetch via columns attr
my $cd = $schema->resultset('CD')->find(1,
join => { 'artist' => {} }
}
);
-ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
+is( $cd->artist->name, 'Caterwauler McCrae', 'single related column prefetched');
# start test for nested prefetch SELECT count
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-$rs = $schema->resultset('Tag')->search(
- { 'me.tagid' => 1 },
- {
- prefetch => { cd => 'artist' }
- }
-);
-
-my $tag = $rs->first;
+my $tag;
+$schema->is_executed_querycount( sub {
+ $rs = $schema->resultset('Tag')->search(
+ { 'me.tagid' => 1 },
+ {
+ prefetch => { cd => 'artist' }
+ }
+ );
-is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
+ $tag = $rs->first;
-is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
+ is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
-# count the SELECTs
-#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
-is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
+ is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
+}, 1, 'nested prefetch ran exactly 1 select statement');
-$queries = 0;
-is($tag->search_related('cd')->search_related('artist')->first->name,
+$schema->is_executed_querycount( sub {
+ is($tag->search_related('cd')->search_related('artist')->first->name,
'Caterwauler McCrae',
'chained belongs_to->belongs_to search_related ok');
+}, 0, 'chained search_related after belongs_to->belongs_to prefetch ran no queries');
-is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
-
-$queries = 0;
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
-is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
+$schema->is_executed_querycount( sub {
+ $cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
-is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
+ is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
+}, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
-$queries = 0;
+$schema->is_executed_querycount( sub {
+ $cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' }, order_by => 'producer.producerid' });
-$schema->storage->debugcb(sub { $queries++; });
+ is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
+}, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
-$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' }, order_by => 'producer.producerid' });
+$schema->is_executed_querycount( sub {
+ my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
-is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
-
-is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
-
-$queries = 0;
-
-my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
-
-is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
-
-is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
+ is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
+}, 0, 'chained search_related after many_to_many prefetch ran no queries');
$rs = $schema->resultset('Tag')->search(
{},
is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
-$cd = $schema->resultset('Artist')->first->create_related('cds',
+$cd = $schema->resultset('Artist')->search({ artistid => 1 })->first->create_related('cds',
{
title => 'Unproduced Single',
year => 2007
cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $tree_like =
- $schema->resultset('TreeLike')->find(5,
- { join => { parent => { parent => 'parent' } },
+my $tree_like;
+$schema->is_executed_querycount( sub {
+ $tree_like =
+ $schema->resultset('TreeLike')->find(5,
+ { join => { parent => { parent => 'parent' } },
prefetch => { parent => { parent => 'parent' } } });
-is($tree_like->name, 'quux', 'Bottom of tree ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'baz', 'First level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'bar', 'Second level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'foo', 'Third level up ok');
+ is($tree_like->name, 'quux', 'Bottom of tree ok');
+ $tree_like = $tree_like->parent;
+ is($tree_like->name, 'baz', 'First level up ok');
+ $tree_like = $tree_like->parent;
+ is($tree_like->name, 'bar', 'Second level up ok');
+ $tree_like = $tree_like->parent;
+ is($tree_like->name, 'foo', 'Third level up ok');
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-cmp_ok($queries, '==', 1, 'Only one query run');
+}, 1, 'Only one query run');
$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 2});
$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
{ 'children.id' => 3, 'children_2.id' => 4 },
{ prefetch => { children => 'children' } }
)->first;
-is(eval { $tree_like->children->first->children->first->name }, 'quux',
+is( $tree_like->children->first->children->first->name, 'quux',
'Tree search_related with prefetch ok');
-$tree_like = eval { $schema->resultset('TreeLike')->search(
+$tree_like = $schema->resultset('TreeLike')->search(
{ 'children.id' => 3, 'children_2.id' => 6 },
{ join => [qw/children children children/] }
)->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' }
- )->first->children->first; };
-is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
+ )->first->children->first;
+is( $tree_like->name, 'fong', 'Tree with multiple has_many joins ok');
$rs = $schema->resultset('Artist');
$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
return $struc;
}
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $prefetch_result = make_hash_struc($art_rs_pr);
-is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
-
-my $nonpre_result = make_hash_struc($art_rs);
+my $prefetch_result;
+$schema->is_executed_querycount( sub {
+ $prefetch_result = make_hash_struc($art_rs_pr);
+}, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
+my $nonpre_result = make_hash_struc($art_rs);
is_deeply( $prefetch_result, $nonpre_result,
'Compare 2 level prefetch result to non-prefetch result' );
-$queries = 0;
-
-is_deeply(
- [ sort map { $_->title } $art_rs_pr->search_related('cds')->search_related('tracks')->all ],
- [ 'Apiary', 'Beehind You', 'Boring Name', 'Boring Song', 'Fowlin', 'Howlin',
- 'No More Ideas', 'Sad', 'Sticky Honey', 'Stripy', 'Stung with Success',
- 'Suicidal', 'The Bees Knees', 'Under The Weather', 'Yowlin' ],
- 'chained has_many->has_many search_related ok'
-);
-
-is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
+$schema->is_executed_querycount( sub {
+ is_deeply(
+ [ sort map { $_->title } $art_rs_pr->search_related('cds')->search_related('tracks')->all ],
+ [ 'Apiary', 'Beehind You', 'Boring Name', 'Boring Song', 'Fowlin', 'Howlin',
+ 'No More Ideas', 'Sad', 'Sticky Honey', 'Stripy', 'Stung with Success',
+ 'Suicidal', 'The Bees Knees', 'Under The Weather', 'Yowlin' ],
+ 'chained has_many->has_many search_related ok'
+ );
+}, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
done_testing;
my $schema = DBICTest->init_schema();
-my $queries;
-my $debugcb = sub { $queries++; };
-my $orig_debug = $schema->storage->debug;
-
lives_ok ( sub {
my $no_prefetch = $schema->resultset('Track')->search_related(cd =>
{
{
my $cd = $schema->resultset('CD')->search({}, { prefetch => 'cd_to_producer' })->find(1);
- $queries = 0;
- $schema->storage->debugcb ($debugcb);
- $schema->storage->debug (1);
-
- is( $cd->cd_to_producer->count, 3 ,'Count of prefetched m2m links via accessor' );
- is( scalar $cd->cd_to_producer->all, 3, 'Amount of prefetched m2m link objects via accessor' );
- is( $cd->search_related('cd_to_producer')->count, 3, 'Count of prefetched m2m links via search_related' );
- is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Amount of prefetched m2m links via search_related' );
-
- is($queries, 0, 'No queries ran so far');
+ $schema->is_executed_querycount( sub {
+ is( $cd->cd_to_producer->count, 3 ,'Count of prefetched m2m links via accessor' );
+ is( scalar $cd->cd_to_producer->all, 3, 'Amount of prefetched m2m link objects via accessor' );
+ is( $cd->search_related('cd_to_producer')->count, 3, 'Count of prefetched m2m links via search_related' );
+ is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Amount of prefetched m2m links via search_related' );
+ }, 0, 'No queries ran so far');
is( scalar $cd->cd_to_producer->search_related('producer')->all, 3,
'Amount of objects via search_related off prefetched linker' );
is( $cd->producers->count, 3,
'Count via m2m accessor' );
- $queries = 0;
-
- is( $cd->cd_to_producer->count, 3 ,'Review count of prefetched m2m links via accessor' );
- is( scalar $cd->cd_to_producer->all, 3, 'Review amount of prefetched m2m link objects via accessor' );
- is( $cd->search_related('cd_to_producer')->count, 3, 'Review count of prefetched m2m links via search_related' );
- is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Rreview amount of prefetched m2m links via search_related' );
-
- is($queries, 0, 'Still no queries on prefetched linker');
- $schema->storage->debugcb (undef);
- $schema->storage->debug ($orig_debug);
+ $schema->is_executed_querycount( sub {
+ is( $cd->cd_to_producer->count, 3 ,'Review count of prefetched m2m links via accessor' );
+ is( scalar $cd->cd_to_producer->all, 3, 'Review amount of prefetched m2m link objects via accessor' );
+ is( $cd->search_related('cd_to_producer')->count, 3, 'Review count of prefetched m2m links via search_related' );
+ is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Rreview amount of prefetched m2m links via search_related' );
+ }, 0, 'Still no queries on prefetched linker');
}
# tests with distinct => 1
is($rs->all, 1, 'distinct with prefetch (objects)');
is($rs->count, 1, 'distinct with prefetch (count)');
- $queries = 0;
- $schema->storage->debugcb ($debugcb);
- $schema->storage->debug (1);
+ local $TODO = "This makes another 2 trips to the database, it can't be right";
+ $schema->is_executed_querycount( sub {
- # artist -> 2 cds -> 2 genres -> 2 cds for each genre + distinct = 2
- is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)');
- is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)');
+ # the is() calls are not todoified
+ local $TODO;
- {
- local $TODO = "This makes another 2 trips to the database, it can't be right";
- is ($queries, 0, 'No extra queries fired (prefetch survives search_related)');
- }
+ # artist -> 2 cds -> 2 genres -> 2 cds for each genre + distinct = 2
+ is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)');
+ is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)');
+
+ }, 0, 'No extra queries fired (prefetch survives search_related)');
- $schema->storage->debugcb (undef);
- $schema->storage->debug ($orig_debug);
}, 'distinct generally works with prefetch on deep search_related chains');
# pathological "user knows what they're doing" case
});
is_deeply(
- $rs->all_hri,
+ $rs->search({}, { order_by => 'me.title' })->all_hri,
[
{ title => "Caterwaulin' Blues", max_trk => 3 },
{ title => "Come Be Depressed With Us", max_trk => 3 },
use Test::More;
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
{'tracks.title' => { '!=' => 'foo' }},
{ order_by => \ 'some oddball literal sql', join => { cds => 'tracks' } }
)->next
- }, qr/A required group_by clause could not be constructed automatically/,
-) || exit;
+ }, qr/Unable to programatically derive a required group_by from the supplied order_by criteria/,
+);
my $artist = $use_prefetch->search({'cds.title' => $artist_many_cds->cds->first->title })->next;
is($artist->cds->count, 1, "count on search limiting prefetched has_many");
use Test::More;
use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
-my $sdebug = $schema->storage->debug;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
my $big_flop_cd = ($artist->search_related('cds'))[3];
is( $big_flop_cd->title, 'Big Flop', 'create_related ok' );
-{ # make sure we are not making pointless select queries when a FK IS NULL
- my $queries = 0;
- $schema->storage->debugcb(sub { $queries++; });
- $schema->storage->debug(1);
+# make sure we are not making pointless select queries when a FK IS NULL
+$schema->is_executed_querycount( sub {
$big_flop_cd->genre; #should not trigger a select query
- is($queries, 0, 'No SELECT made for belongs_to if key IS NULL');
+}, 0, 'No SELECT made for belongs_to if key IS NULL');
+
+$schema->is_executed_querycount( sub {
$big_flop_cd->genre_inefficient; #should trigger a select query
- is($queries, 1, 'SELECT made for belongs_to if key IS NULL when undef_on_null_fk disabled');
- $schema->storage->debug($sdebug);
- $schema->storage->debugcb(undef);
-}
+}, 1, 'SELECT made for belongs_to if key IS NULL when undef_on_null_fk disabled');
my( $rs_from_list ) = $artist->search_related_rs('cds');
isa_ok( $rs_from_list, 'DBIx::Class::ResultSet', 'search_related_rs in list context returns rs' );
'many_to_many add_to_$rel($hash) ok' );
$cd->add_to_producers({ name => 'Jack Black' });
is( $prod_rs->count(), 2, 'many_to_many add_to_$rel($hash) count ok' );
-$cd->set_producers($schema->resultset('Producer')->all);
-is( $cd->producers->count(), $prod_before_count+2,
- 'many_to_many set_$rel(@objs) count ok' );
-$cd->set_producers($schema->resultset('Producer')->find(1));
-is( $cd->producers->count(), 1, 'many_to_many set_$rel($obj) count ok' );
+
+warnings_like {
+ $cd->set_producers($schema->resultset('Producer')->all);
+ is( $cd->producers->count(), $prod_before_count+2,
+ 'many_to_many set_$rel(@objs) count ok' );
+
+ $cd->set_producers($schema->resultset('Producer')->find(1));
+ is( $cd->producers->count(), 1, 'many_to_many set_$rel($obj) count ok' );
+} [
+ ( qr/\QCalling 'set_producers' with a list of items to link to is deprecated, use an arrayref instead/ ) x 2
+], 'Warnings on deprecated invocation of set_* found';
+
+warnings_like {
+ is( $cd->producers( producerid => '666' )->count, 0 );
+} [
+ qr/\Qsearch( %condition ) is deprecated/
+], 'Warning properly bubbled from search()';
+
$cd->set_producers([$schema->resultset('Producer')->all]);
is( $cd->producers->count(), $prod_before_count+2,
'many_to_many set_$rel(\@objs) count ok' );
throws_ok {
$cd->remove_from_producers({ fake => 'hash' })
-} qr/needs an object/, 'remove_from_$rel($hash) dies correctly';
+} qr/expects an object/, 'remove_from_$rel($hash) dies correctly';
throws_ok {
$cd->add_to_producers()
-} qr/needs an object or hashref/, 'add_to_$rel(undef) dies correctly';
+} qr/expects an object or hashref/, 'add_to_$rel(undef) dies correctly';
# many_to_many stresstest
my $twokey = $schema->resultset('TwoKeys')->find(1,1);
my $undef_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007 });
-is($undef_artist_cd->has_column_loaded('artist'), '', 'FK not loaded');
+ok(! $undef_artist_cd->has_column_loaded('artist'), 'FK not loaded');
is($undef_artist_cd->search_related('artist')->count, 0, '0=1 search when FK does not exist and object not yet in db');
lives_ok {
$undef_artist_cd->related_resultset('artist')->new({name => 'foo'});
$undir_maps = $schema->resultset("Artist")->find(2)->artist_undirected_maps;
is($undir_maps->count, 1, 'found 1 undirected map for artist 2');
+{
+ my $artist_to_mangle = $schema->resultset('Artist')->find(2);
+
+ $artist_to_mangle->set_from_related( artist_undirected_maps => { id1 => 42 } );
+
+ ok( ! $artist_to_mangle->is_changed, 'Unresolvable set_from_related did not alter object' );
+
+ $artist_to_mangle->set_from_related( artist_undirected_maps => {} );
+ ok( $artist_to_mangle->is_changed, 'Definitive set_from_related did alter object' );
+ is (
+ $artist_to_mangle->id,
+ undef,
+ 'Correctly unset id on definitive outcome of OR condition',
+ );
+}
+
my $mapped_rs = $undir_maps->search_related('mapped_artists');
my @art = $mapped_rs->all;
use Test::More;
use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
)',
[
[
- { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ {}
=> 21
],
[
} 'prefetchy-fetchy-fetch';
+# create_related a plain cd via the equoivalent coderef cond, with no extra conditions
+lives_ok {
+ $artist->create_related('cds_cref_cond', { title => 'related creation via coderef cond', year => '2010' } );
+} 'created_related with simple condition works';
# try to create_related a 80s cd
throws_ok {
$artist->create_related('cds_80s', { title => 'related creation 1' });
-} qr/\QCustom relationship 'cds_80s' not definitive - returns conditions instead of values for column(s): 'year'/,
+} qr/\QUnable to complete value inferrence - custom relationship 'cds_80s' on source 'Artist' returns conditions instead of values for column(s): 'year'/,
'Create failed - complex cond';
# now supply an explicit arg overwriting the ambiguous cond
-my $id_2020 = $artist->create_related('cds_80s', { title => 'related creation 2', year => '2020' })->id;
+my $cd_2020 = $artist->create_related('cds_80s', { title => 'related creation 2', year => '2020' });
+my $id_2020 = $cd_2020->id;
is(
$schema->resultset('CD')->find($id_2020)->title,
'related creation 2',
# try a specific everything via a non-simplified rel
throws_ok {
$artist->create_related('cds_90s', { title => 'related_creation 4', year => '2038' });
-} qr/\QCustom relationship 'cds_90s' does not resolve to a join-free condition fragment/,
+} qr/\QRelationship 'cds_90s' on source 'Artist' does not resolve to a join-free condition fragment/,
'Create failed - non-simplified rel';
# Do a self-join last-entry search
'last_track via insane subquery condition works, even without prefetch',
);
+
my $artwork = $schema->resultset('Artwork')->search({},{ order_by => 'cd_id' })->first;
-my @artists = $artwork->artists->all;
+my @artists = $artwork->artists->search({}, { order_by => 'artistid' } );
is(scalar @artists, 2, 'the two artists are associated');
my @artwork_artists = $artwork->artwork_to_artist->all;
foreach (@artwork_artists) {
lives_ok {
my $artista = $_->artist;
- my $artistb = $_->artist_test_m2m;
+ my $artistb = $_->artist_limited_rank;
ok($artista->rank < 10 ? $artistb : 1, 'belongs_to with custom rel works.');
- my $artistc = $_->artist_test_m2m_noopt;
+ my $artistc = $_->artist_limited_rank_opaque;
ok($artista->rank < 10 ? $artistc : 1, 'belongs_to with custom rel works even in non-simplified.');
} 'belongs_to works with custom rels';
}
-@artists = ();
-lives_ok {
- @artists = $artwork->artists_test_m2m2->all;
-} 'manytomany with extended rels in the has many works';
-is(scalar @artists, 2, 'two artists');
+is(
+ $schema->resultset('Artwork')
+ ->related_resultset( 'artwork_to_artist_via_opaque_customcond' )
+ ->related_resultset( 'artist' )
+ ->search({}, { collapse => 1 })
+ ->count,
+ 2,
+ 'Custom rel works correctly',
+);
-@artists = ();
-lives_ok {
- @artists = $artwork->artists_test_m2m->all;
-} 'can fetch many to many with optimized version';
-is(scalar @artists, 1, 'only one artist is associated');
+is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 2,
+ 'Expected two m2m associated artist objects via opaque costom cond'
+);
-@artists = ();
-lives_ok {
- @artists = $artwork->artists_test_m2m_noopt->all;
-} 'can fetch many to many with non-optimized version';
-is(scalar @artists, 1, 'only one artist is associated');
+for (qw( artist_limited_rank artist_limited_rank_opaque )) {
+ is(
+ $schema->resultset('Artwork')
+ ->related_resultset( 'artwork_to_artist_via_opaque_customcond' )
+ ->related_resultset( $_ )
+ ->search({}, { collapse => 1 })
+ ->count,
+ 1,
+ 'Condition over double custom rel works correctly',
+ );
+
+ is (
+ scalar $artwork->$_->all,
+ 1,
+ 'Expected one m2m associated artist object via opaque custom cond + conditional far cond'
+ );
+
+ cmp_ok(
+ $artwork->${\"remove_from_$_"} ( $artists[1] ),
+ '==',
+ 0,
+ 'deletion action reports 0'
+ );
+
+ is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 2,
+ 'Indeed nothing was removed'
+ );
+
+ cmp_ok(
+ $artwork->${\"remove_from_$_"} ( $artists[0] ),
+ '==',
+ 1,
+ 'Removal reports correct count'
+ );
+
+ is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 1,
+ 'Indeed removed the matching artist'
+ );
+
+ $artwork->${\"set_$_"}([]);
+
+ is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 0,
+ 'Everything removed via limited far cond'
+ );
+
+ # can't use the opaque one - need set_from_related to work
+ $artwork->set_artist_limited_rank( \@artists );
+
+ {
+ local $TODO = 'Taking into account the relationship bridge condition is not likely to ever work... unless we get DQ hooked somehow';
+
+ is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 1,
+ 'Re-Addition passed through only one of the artists'
+ );
+ }
+
+ throws_ok { $artwork->set_all_artists_via_opaque_customcond( \@artists ) }
+ qr/\QRelationship 'artwork_to_artist_via_opaque_customcond' on source 'Artwork' does not resolve to a join-free condition fragment/;
+
+ is (
+ scalar $artwork->all_artists_via_opaque_customcond->all,
+ 2,
+ 'Everything still there as expected'
+ );
+}
# Make a single for each last_track
'Prefetched singles in proper order'
);
+# test set_from_related/find_related with a belongs_to custom condition
+my $preexisting_cd = $schema->resultset('CD')->find(1);
+
+my $cd_single_track = $schema->resultset('CD')->create({
+ artist => $artist,
+ title => 'one one one',
+ year => 2001,
+ tracks => [{ title => 'uno uno uno' }]
+});
+
+my $single_track = $cd_single_track->tracks->next;
+
+is(
+ $single_track->cd_cref_cond->title,
+ $cd_single_track->title,
+ 'Got back the expected single-track cd title',
+);
+
+is_deeply
+ { $schema->resultset('Track')->find({ cd_cref_cond => { cdid => $cd_single_track->id } })->get_columns },
+ { $single_track->get_columns },
+ 'Proper find with related via coderef cond',
+;
+
+warnings_exist {
+ is_same_sql_bind(
+ $single_track->deliberately_broken_all_cd_tracks->as_query,
+ '(
+ SELECT me.trackid, me.cd, me.position, me.title, me.last_updated_on, me.last_updated_at
+ FROM track track__row
+ JOIN track me
+ ON me.cd = ?
+ WHERE track__row.trackid = ?
+ )',
+ [
+ [{ dbic_colname => "me.cd", sqlt_datatype => "integer" }
+ => "track__row.cd" ],
+ [{ dbic_colname => "track__row.trackid", sqlt_datatype => "integer" }
+ => 19 ],
+ ],
+ 'Expected nonsensical JOIN cond',
+ ),
+} qr/\Qrelationship 'deliberately_broken_all_cd_tracks' on source 'Track' specifies equality of column 'cd' and the *VALUE* 'cd' (you did not use the { -ident => ... } operator)/,
+ 'Warning on 99.9999% malformed custom cond'
+;
+
+$single_track->set_from_related( cd_cref_cond => undef );
+ok $single_track->is_column_changed('cd');
+is $single_track->get_column('cd'), undef, 'UNset from related via coderef cond';
+is $single_track->cd, undef, 'UNset related object via coderef cond';
+
+$single_track->discard_changes;
+
+$single_track->set_from_related( cd_cref_cond => $preexisting_cd );
+ok $single_track->is_column_changed('cd');
+is $single_track->get_column('cd'), 1, 'set from related via coderef cond';
+is_deeply
+ { $single_track->cd->get_columns },
+ { $preexisting_cd->get_columns },
+ 'set from related via coderef cond inflates properly',
+;
+
+throws_ok {
+ local $schema->source('Track')->relationship_info('cd_cref_cond')->{cond} = sub { 1,2,3 };
+ $schema->resultset('Track')->find({ cd_cref_cond => {} });
+} qr/\QA custom condition coderef can return at most 2 conditions, but relationship 'cd_cref_cond' on source 'Track' returned extra values: 3/;
+
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 't/lib';
+use DBICTest;
+
+my $schema = DBICTest->init_schema( no_populate => 1, quote_names => 1 );
+
+$schema->resultset('CD')->create({
+ title => 'Equinoxe',
+ year => 1978,
+ artist => { name => 'JMJ' },
+ genre => { name => 'electro' },
+ tracks => [
+ { title => 'e1' },
+ { title => 'e2' },
+ { title => 'e3' },
+ ],
+ single_track => {
+ title => 'o1',
+ cd => {
+ title => 'Oxygene',
+ year => 1976,
+ artist => { name => 'JMJ' },
+ },
+ },
+});
+
+my $cd = $schema->resultset('CD')->search({ single_track => { '!=', undef } })->first;
+
+$schema->is_executed_sql_bind(
+ sub { is( eval{$cd->single_track_opaque->title}, 'o1', 'Found correct single track' ) },
+ [
+ [
+ 'SELECT "me"."trackid", "me"."cd", "me"."position", "me"."title", "me"."last_updated_on", "me"."last_updated_at"
+ FROM cd "cd__row"
+ JOIN "track" "me"
+ ON me.trackid = cd__row.single_track
+ WHERE "cd__row"."cdid" = ?
+ ',
+ [
+ { dbic_colname => "cd__row.cdid", sqlt_datatype => "integer" }
+ => 2
+ ]
+ ],
+ ],
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib 't/lib';
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+for (
+ { year => [1,2] },
+ { year => ['-and',1,2] },
+ { -or => [ year => 1, year => 2 ] },
+ { -and => [ year => 1, year => 2 ] },
+) {
+ throws_ok {
+ $schema->source('Track')->_resolve_relationship_condition(
+ rel_name => 'cd_cref_cond',
+ self_alias => 'me',
+ foreign_alias => 'cd',
+ foreign_values => $_
+ );
+ } qr/
+ \Qis not a column on related source 'CD'\E
+ |
+ \QValue supplied for '...{foreign_values}{year}' is not a direct equivalence expression\E
+ /x;
+}
+
+done_testing;
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
-my $sdebug = $schema->storage->debug;
my $artist = $schema->resultset ('Artist')->find(1);
# expect a create, after a failed search using *only* the
# *current* relationship and the unique column constraints
# (so no year)
-my @sql;
-$schema->storage->debugcb(sub { push @sql, $_[1] });
-$schema->storage->debug (1);
-
-$genre->update_or_create_related ('cds', {
- title => 'the best thing since vertical toasters',
- artist => $artist,
- year => 2012,
-});
-
-$schema->storage->debugcb(undef);
-$schema->storage->debug ($sdebug);
-
-my ($search_sql) = $sql[0] =~ /^(SELECT .+?)\:/;
-is_same_sql (
- $search_sql,
- 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me
- WHERE ( me.artist = ? AND me.title = ? AND me.genreid = ? )
- ',
- 'expected select issued',
-);
+$schema->is_executed_sql_bind( sub {
+ $genre->update_or_create_related ('cds', {
+ title => 'the best thing since vertical toasters',
+ artist => $artist,
+ year => 2012,
+ });
+}, [
+ [
+ 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ WHERE ( me.artist = ? AND me.genreid = ? AND me.title = ? )
+ ',
+ 1,
+ 2,
+ "the best thing since vertical toasters",
+ ],
+ [
+ 'INSERT INTO cd ( artist, genreid, title, year) VALUES ( ?, ?, ?, ? )',
+ 1,
+ 2,
+ "the best thing since vertical toasters",
+ 2012,
+ ],
+], 'expected select issued' );
# a has_many search without a unique constraint makes no sense
# but I am not sure what to test for - leaving open
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
my $art_rs = $schema->resultset('Artist');
{
is_same_sql_bind(
$art_rs->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ $rank_resolved_bind, $name_resolved_bind ],
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE name = ? AND rank = ? )",
+ [ $name_resolved_bind, $rank_resolved_bind ],
);
}
{
is_same_sql_bind(
$rscol->as_query,
- "(SELECT me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ $rank_resolved_bind, $name_resolved_bind ],
+ "(SELECT me.charfield FROM artist me WHERE name = ? AND rank = ? )",
+ [ $name_resolved_bind, $rank_resolved_bind ],
);
}
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
'Resultset-class attributes do not seep outside of the subselect',
);
-$schema->storage->debug(1);
-
is_same_sql_bind(
$schema->resultset('CD')->search ({}, {
rows => 2,
[ [{ sqlt_datatype => 'integer' } => 2 ] ],
);
-
done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema;
my $rs;
{
- local $TODO = 'bind args order needs fixing (semifor)';
-
# First, the simple cases...
$rs = $schema->resultset('Artist')->search(
{ artistid => 1 },
is ( $rs->count, 1, 'where/bind last' );
# and the complex case
- local $TODO = 'bind args order needs fixing (semifor)';
$rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] })
->search({ 'artistid' => 1 }, {
where => \'title like ?',
use Test::More;
use Test::Exception;
+use Math::BigInt;
use lib qw(t/lib);
use DBICTest;
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
-}
-
my $schema = DBICTest->init_schema();
my $artist_rs = $schema->resultset('Artist');
my $cd_rs = $schema->resultset('CD');
}
{
- my $formatter = DateTime::Format::Strptime->new(pattern => '%Y');
- my $dt = DateTime->new(year => 2006, month => 06, day => 06,
- formatter => $formatter );
+ my $dt = Math::BigInt->new(2006);
+
my $cd;
lives_ok {
$cd = $cd_rs->search({ year => $dt})->create
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+my $rs = $schema->resultset('Artist');
+
+for my $id (
+ 2,
+ \' = 2 ',
+ \[ '= ?', 2 ],
+) {
+ lives_ok {
+ is( $rs->find({ artistid => $id })->id, 2 )
+ } "Correctly found artist with id of @{[ explain $id ]}";
+}
+
+for my $id (
+ 2,
+ \'2',
+ \[ '?', 2 ],
+) {
+ my $cond = { artistid => { '=', $id } };
+ lives_ok {
+ is( $rs->find($cond)->id, 2 )
+ } "Correctly found artist with id of @{[ explain $cond ]}";
+}
+
+done_testing;
cmp_deeply($left, $right, $msg||()) or next INFTYPE;
}
+{
+ package DBICTest::_DoubleResult;
+
+ sub inflate_result {
+ my $class = shift;
+ return map { DBIx::Class::ResultClass::HashRefInflator->inflate_result(@_) } (1,2);
+ }
+}
+
+my $oxygene_rs = $schema->resultset('CD')->search({ 'me.title' => 'Oxygene' });
+
+is_deeply(
+ [ $oxygene_rs->search({}, { result_class => 'DBICTest::_DoubleResult' })->all ],
+ [ ({ $oxygene_rs->single->get_columns }) x 2 ],
+);
+
+is_deeply(
+ [ $oxygene_rs->search({}, {
+ result_class => 'DBICTest::_DoubleResult', prefetch => [qw(artist tracks)],
+ order_by => [qw(me.cdid tracks.title)],
+ })->all ],
+ [ (@{$oxygene_rs->search({}, {
+ prefetch=> [qw(artist tracks)],
+ order_by => [qw(me.cdid tracks.title)],
+ })->all_hri}) x 2 ],
+);
+
done_testing;
use warnings;
use Test::More;
+use Math::BigInt;
use lib qw(t/lib);
use DBICTest;
'extra columns returned by get_inflated_columns without inflatable columns',
);
-SKIP: {
- skip (
- "+select/get_inflated_columns tests need " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt'),
- 1
- ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
-
- $schema->class('CD')->inflate_column( 'year',
- { inflate => sub { DateTime->new( year => shift ) },
- deflate => sub { shift->year } }
- );
+# Test object inflation
+$schema->class('CD')->inflate_column( 'year',
+ { inflate => sub { Math::BigInt->new( shift ) },
+ deflate => sub { shift() . '' } }
+);
- $basecols{year} = DateTime->new ( year => $basecols{year} );
+$basecols{year} = Math::BigInt->new( $basecols{year} );
- is_deeply (
- { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override },
- { %basecols, tr_cnt => $track_cnt },
- 'extra columns returned by get_inflated_columns',
- );
-}
+is_deeply (
+ { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override },
+ { %basecols, tr_cnt => $track_cnt },
+ 'extra columns returned by get_inflated_columns',
+);
done_testing;
use lib qw(t/lib);
use DBICTest;
use B::Deparse;
+use DBIx::Class::_Util 'perlstring';
# globally set for the rest of test
# the rowparser maker does not order its hashes by default for the miniscule
my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
- $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0";
- $cur_row_ids{1} = $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0";
- $cur_row_ids{3} = $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0";
- $cur_row_ids{4} = $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0";
- $cur_row_ids{5} = $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0";
+ ( @cur_row_ids{0,1,3,4,5} = (
+ ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0" ),
+ ( $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0" ),
+ ( $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0" ),
+ ( $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0" ),
+ ( $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0" ),
+ ) ),
# a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} and (unshift @{$_[2]}, $cur_row_data) and last;
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} and (unshift @{$_[2]}, $cur_row_data) and last ),
# the rowdata itself for root node
- $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} //= $_[0][$result_pos++] = [{ artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] }];
+ ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} //= $_[0][$result_pos++] = [{ artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] }] ),
# prefetch data of single_track (placed in root)
- $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [];
- defined($cur_row_data->[1]) or bless( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track}, __NBC__ );
+ ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [] ),
+ ( defined($cur_row_data->[1]) or bless( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track}, __NBC__ ) ),
# prefetch data of cd (placed in single_track)
- $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [];
+ ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [] ),
# prefetch data of artist ( placed in single_track->cd)
- $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ artistid => $cur_row_data->[1] }];
+ ( $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ artistid => $cur_row_data->[1] }] ),
# prefetch data of cds (if available)
- (! $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
- and
- push @{$collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}}, (
- $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ cdid => $cur_row_data->[3] }]
- );
- defined($cur_row_data->[3]) or bless( $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}, __NBC__ );
+ (
+ (! $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
+ and
+ push @{$collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}}, (
+ $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ cdid => $cur_row_data->[3] }]
+ )
+ ),
+ ( defined($cur_row_data->[3]) or bless( $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}, __NBC__ ) ),
# prefetch data of tracks (if available)
- (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
- and
- push @{$collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}}, (
- $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ title => $cur_row_data->[0] }]
- );
- defined($cur_row_data->[0]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}, __NBC__ );
+ (
+ (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
+ and
+ push @{$collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}}, (
+ $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ title => $cur_row_data->[0] }]
+ )
+ ),
+ ( defined($cur_row_data->[0]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}, __NBC__ ) ),
}
$#{$_[0]} = $result_pos - 1;
prune_null_branches => 1,
}))[0],
' my $rows_pos = 0;
- my ($result_pos, @collapse_idx, $cur_row_data);
+ my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
+ ( @cur_row_ids{0, 1, 3, 4, 5} = @{$cur_row_data}[0, 1, 3, 4, 5] ),
+
# a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]} and (unshift @{$_[2]}, $cur_row_data) and last;
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} and (unshift @{$_[2]}, $cur_row_data) and last ),
# the rowdata itself for root node
- $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]} //= $_[0][$result_pos++] = { artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] };
+ ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} //= $_[0][$result_pos++] = { artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] } ),
# prefetch data of single_track (placed in root)
- (! defined($cur_row_data->[1]) ) ? $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]}{single_track} = undef : do {
- $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]}{single_track} //= $collapse_idx[1]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]};
+ ( (! defined($cur_row_data->[1]) ) ? $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} = undef : do {
+ ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ),
# prefetch data of cd (placed in single_track)
- $collapse_idx[1]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cd} //= $collapse_idx[2]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]};
+ ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ),
# prefetch data of artist ( placed in single_track->cd)
- $collapse_idx[2]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{artist} //= $collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { artistid => $cur_row_data->[1] };
+ ( $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = { artistid => $cur_row_data->[1] } ),
# prefetch data of cds (if available)
- (! defined $cur_row_data->[3] ) ? $collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cds} = [] : do {
+ ( (! defined $cur_row_data->[3] ) ? $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cds} = [] : do {
- (! $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} )
- and
- push @{$collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cds}}, (
- $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { cdid => $cur_row_data->[3] }
- );
+ (
+ (! $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
+ and
+ push @{$collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cds}}, (
+ $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = { cdid => $cur_row_data->[3] }
+ )
+ ),
# prefetch data of tracks (if available)
- ( ! defined $cur_row_data->[0] ) ? $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]}{tracks} = [] : do {
-
- (! $collapse_idx[5]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} )
- and
- push @{$collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]}{tracks}}, (
- $collapse_idx[5]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { title => $cur_row_data->[0] }
- );
- };
- };
- };
+ (( ! defined $cur_row_data->[0] ) ? $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}{tracks} = [] : do {
+
+ (
+ (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} )
+ and
+ push @{$collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}{tracks}}, (
+ $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = { title => $cur_row_data->[0] }
+ )
+ ),
+ } ),
+ } ),
+ } ),
}
$#{$_[0]} = $result_pos - 1;
',
my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
- $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0";
- $cur_row_ids{1} = $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0";
- $cur_row_ids{5} = $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0";
- $cur_row_ids{6} = $cur_row_data->[6] // "\0NULL\xFF$rows_pos\xFF6\0";
- $cur_row_ids{8} = $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0";
- $cur_row_ids{10} = $cur_row_data->[10] // "\0NULL\xFF$rows_pos\xFF10\0";
+ ( @cur_row_ids{0, 1, 5, 6, 8, 10} = (
+ $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0",
+ $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0",
+ $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0",
+ $cur_row_data->[6] // "\0NULL\xFF$rows_pos\xFF6\0",
+ $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0",
+ $cur_row_data->[10] // "\0NULL\xFF$rows_pos\xFF10\0",
+ ) ),
# a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{1}} and (unshift @{$_[2]}, $cur_row_data) and last;
-
- $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] }];
-
- (! $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->[6]) or bless( $collapse_idx[3]{$cur_row_ids{1}}[1]{cds}, __NBC__ );
-
- (! $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->[8]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}}[1]{tracks}, __NBC__ );
-
- (! $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->[5]) or bless( $collapse_idx[0]{$cur_row_ids{1}}[1]{tracks}, __NBC__ );
-
- $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}} = [];
- defined($cur_row_data->[10]) or bless( $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}}[1]{lyrics}, __NBC__ );
-
- (! $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] }]
- );
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{1}} and (unshift @{$_[2]}, $cur_row_data) and last ),
+
+ ( $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] }] ),
+
+ (
+ (! $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->[6]) or bless( $collapse_idx[3]{$cur_row_ids{1}}[1]{cds}, __NBC__ ) ),
+
+ (
+ (! $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->[8]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}}[1]{tracks}, __NBC__ ) ),
+
+ (
+ (! $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->[5]) or bless( $collapse_idx[0]{$cur_row_ids{1}}[1]{tracks}, __NBC__ ) ),
+
+ ( $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}} = [] ),
+ ( defined($cur_row_data->[10]) or bless( $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}}[1]{lyrics}, __NBC__ ) ),
+
+ (
+ (! $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;
prune_null_branches => 1,
}))[0],
' my $rows_pos = 0;
- my ($result_pos, @collapse_idx, $cur_row_data);
+ my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
- # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_data->[1]} and (unshift @{$_[2]}, $cur_row_data) and last;
+ ( @cur_row_ids{( 0, 1, 5, 6, 8, 10 )} = @{$cur_row_data}[( 0, 1, 5, 6, 8, 10 )] ),
- $collapse_idx[0]{$cur_row_data->[1]} //= $_[0][$result_pos++] = [{ genreid => $cur_row_data->[4], latest_cd => $cur_row_data->[7], year => $cur_row_data->[3] }];
+ # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{1}} and (unshift @{$_[2]}, $cur_row_data) and last ),
- $collapse_idx[0]{$cur_row_data->[1]}[1]{existing_single_track} //= $collapse_idx[1]{$cur_row_data->[1]} = [];
- $collapse_idx[1]{$cur_row_data->[1]}[1]{cd} //= $collapse_idx[2]{$cur_row_data->[1]} = [];
- $collapse_idx[2]{$cur_row_data->[1]}[1]{artist} //= $collapse_idx[3]{$cur_row_data->[1]} = [{ artistid => $cur_row_data->[1] }];
+ ( $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] }] ),
- (! defined($cur_row_data->[6])) ? $collapse_idx[3]{$cur_row_data->[1]}[1]{cds} = [] : do {
- (! $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]} )
- and
- push @{ $collapse_idx[3]{$cur_row_data->[1]}[1]{cds} }, (
- $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]} = [{ cdid => $cur_row_data->[6], genreid => $cur_row_data->[9], year => $cur_row_data->[2] }]
- );
+ ( $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->[8]) ) ? $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]}[1]{tracks} = [] : do {
-
- (! $collapse_idx[5]{$cur_row_data->[1]}{$cur_row_data->[6]}{$cur_row_data->[8]} )
+ ( (! 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[4]{$cur_row_data->[1]}{$cur_row_data->[6]}[1]{tracks} }, (
- $collapse_idx[5]{$cur_row_data->[1]}{$cur_row_data->[6]}{$cur_row_data->[8]} = [{ title => $cur_row_data->[8] }]
- );
- };
- };
+ 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_data->[1]}[1]{tracks} = [] : do {
+ ( (! defined($cur_row_data->[5]) ) ? $collapse_idx[0]{$cur_row_ids{1}}[1]{tracks} = [] : do {
- (! $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]} )
- and
- push @{ $collapse_idx[0]{$cur_row_data->[1]}[1]{tracks} }, (
- $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]} = [{ title => $cur_row_data->[5] }]
- );
+ (
+ (! $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_data->[1]}{$cur_row_data->[5]}[1]{lyrics} = [] : do {
+ ( (! defined($cur_row_data->[10]) ) ? $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}}[1]{lyrics} = [] : do {
- $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]}[1]{lyrics} //= $collapse_idx[7]{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} = [];
+ ( $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_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} )
- and
- push @{ $collapse_idx[7]{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]}[1]{existing_lyric_versions} }, (
- $collapse_idx[8]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} = [{ lyric_id => $cur_row_data->[10], text => $cur_row_data->[0] }]
- );
- };
- };
+ (
+ (! $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;
my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
- $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0";
- $cur_row_ids{2} = $cur_row_data->[2] // "\0NULL\xFF$rows_pos\xFF2\0";
- $cur_row_ids{3} = $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0";
- $cur_row_ids{4} = $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0";
- $cur_row_ids{8} = $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0";
+ ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = (
+ $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0",
+ $cur_row_data->[2] // "\0NULL\xFF$rows_pos\xFF2\0",
+ $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0",
+ $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0",
+ $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0",
+ )),
# cache expensive set of ops in a non-existent rowid slot
- $cur_row_ids{10} = (
- ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_data->[0], q{} ))
+ ( $cur_row_ids{10} = (
+ ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_ids{0}, q{} ))
or
- ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_data->[2], q{} ))
+ ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_ids{2}, q{} ))
or
"\0$rows_pos\0"
- );
+ )),
# a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last;
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last ),
- $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = [{ year => $$cur_row_data[1] }];
+ ( $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = [{ year => $$cur_row_data[1] }] ),
- $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = [{ trackid => $cur_row_data->[0] }]);
- defined($cur_row_data->[0]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track}, __NBC__ );
+ ( $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = [{ trackid => $cur_row_data->[0] }]) ),
+ ( defined($cur_row_data->[0]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track}, __NBC__ ) ),
- $collapse_idx[1]{$cur_row_ids{0}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{0}} = [];
+ ( $collapse_idx[1]{$cur_row_ids{0}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{0}} = [] ),
- $collapse_idx[2]{$cur_row_ids{0}}[1]{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = [{ artistid => $cur_row_data->[6] }]);
+ ( $collapse_idx[2]{$cur_row_ids{0}}[1]{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = [{ artistid => $cur_row_data->[6] }]) ),
- (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} )
- and
- push @{$collapse_idx[3]{$cur_row_ids{0}}[1]{cds}}, (
+ (
+ (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} )
+ and
+ push @{$collapse_idx[3]{$cur_row_ids{0}}[1]{cds}}, (
$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} = [{ cdid => $cur_row_data->[4], genreid => $cur_row_data->[7], year => $cur_row_data->[5] }]
- );
- defined($cur_row_data->[4]) or bless ( $collapse_idx[3]{$cur_row_ids{0}}[1]{cds}, __NBC__ );
-
- (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} )
- and
- push @{$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}}, (
- $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} = [{ title => $cur_row_data->[8] }]
- );
- defined($cur_row_data->[8]) or bless ( $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}, __NBC__ );
-
- (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} )
- and
- push @{$collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}}, (
+ )
+ ),
+ ( defined($cur_row_data->[4]) or bless ( $collapse_idx[3]{$cur_row_ids{0}}[1]{cds}, __NBC__ ) ),
+
+ (
+ (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} )
+ and
+ push @{$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}}, (
+ $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} = [{ title => $cur_row_data->[8] }]
+ )
+ ),
+ ( defined($cur_row_data->[8]) or bless ( $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}, __NBC__ ) ),
+
+ (
+ (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} )
+ and
+ push @{$collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}}, (
$collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} = [{ cd => $$cur_row_data[2], title => $cur_row_data->[3] }]
- );
- defined($cur_row_data->[2]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}, __NBC__ );
+ )
+ ),
+ ( defined($cur_row_data->[2]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}, __NBC__ ) ),
}
$#{$_[0]} = $result_pos - 1;
my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids);
while ($cur_row_data = (
- ( $rows_pos >= 0 and $_[0][$rows_pos++] )
- ||
- ( $_[1] and $rows_pos = -1 and $_[1]->() )
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
) ) {
# do not care about nullability here
- $cur_row_ids{0} = $cur_row_data->[0];
- $cur_row_ids{2} = $cur_row_data->[2];
- $cur_row_ids{3} = $cur_row_data->[3];
- $cur_row_ids{4} = $cur_row_data->[4];
- $cur_row_ids{8} = $cur_row_data->[8];
+ ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = @{$cur_row_data}[( 0, 2, 3, 4, 8 )] ),
# cache expensive set of ops in a non-existent rowid slot
- $cur_row_ids{10} = (
- ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_data->[0], q{} ))
+ ( $cur_row_ids{10} = (
+ ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_ids{0}, q{} ))
or
- ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_data->[2], q{} ))
+ ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_ids{2}, q{} ))
or
"\0$rows_pos\0"
- );
+ )),
# a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2]
- $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last;
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last ),
- $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = { year => $$cur_row_data[1] };
+ ( $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = { year => $$cur_row_data[1] } ),
- (! defined $cur_row_data->[0] ) ? $collapse_idx[0]{$cur_row_ids{10}}{single_track} = undef : do {
+ ( (! defined $cur_row_data->[0] ) ? $collapse_idx[0]{$cur_row_ids{10}}{single_track} = undef : do {
- $collapse_idx[0]{$cur_row_ids{10}}{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = { trackid => $$cur_row_data[0] });
+ ( $collapse_idx[0]{$cur_row_ids{10}}{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = { trackid => $$cur_row_data[0] }) ),
- $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}};
+ ( $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}} ),
- $collapse_idx[2]{$cur_row_ids{0}}{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = { artistid => $$cur_row_data[6] });
+ ( $collapse_idx[2]{$cur_row_ids{0}}{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = { artistid => $$cur_row_data[6] }) ),
- (! defined $cur_row_data->[4] ) ? $collapse_idx[3]{$cur_row_ids{0}}{cds} = [] : do {
+ ( (! defined $cur_row_data->[4] ) ? $collapse_idx[3]{$cur_row_ids{0}}{cds} = [] : do {
- (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} )
- and
- push @{$collapse_idx[3]{$cur_row_ids{0}}{cds}}, (
- $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} = { cdid => $$cur_row_data[4], genreid => $$cur_row_data[7], year => $$cur_row_data[5] }
- );
+ (
+ (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} )
+ and
+ push @{$collapse_idx[3]{$cur_row_ids{0}}{cds}}, (
+ $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} = { cdid => $$cur_row_data[4], genreid => $$cur_row_data[7], year => $$cur_row_data[5] }
+ )
+ ),
- (! defined $cur_row_data->[8] ) ? $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}{tracks} = [] : do {
+ ( (! defined $cur_row_data->[8] ) ? $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}{tracks} = [] : do {
(! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} )
and
push @{$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}{tracks}}, (
$collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} = { title => $$cur_row_data[8] }
- );
- };
- };
- };
-
- (! defined $cur_row_data->[2] ) ? $collapse_idx[0]{$cur_row_ids{10}}{tracks} = [] : do {
- (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} )
- and
- push @{$collapse_idx[0]{$cur_row_ids{10}}{tracks}}, (
+ ),
+ } ),
+ } ),
+ } ),
+
+ ( (! defined $cur_row_data->[2] ) ? $collapse_idx[0]{$cur_row_ids{10}}{tracks} = [] : do {
+ (
+ (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} )
+ and
+ push @{$collapse_idx[0]{$cur_row_ids{10}}{tracks}}, (
$collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} = { cd => $$cur_row_data[2], title => $$cur_row_data[3] }
- );
- };
+ )
+ ),
+ } ),
}
$#{$_[0]} = $result_pos - 1;
'Multiple has_many on multiple branches with underdefined root, HRI-direct torture test',
);
+is_same_src (
+ ($schema->source ('Owners')->_mk_row_parser({
+ inflate_map => [qw( books.title books.owner )],
+ collapse => 1,
+ prune_null_branches => 1,
+ }))[0],
+ ' my $rows_pos = 0;
+ my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids );
+
+ while ($cur_row_data = (
+ (
+ $rows_pos >= 0
+ and
+ (
+ $_[0][$rows_pos++]
+ or
+ ( ($rows_pos = -1), undef )
+ )
+ )
+ or
+ ( $_[1] and $_[1]->() )
+ ) ) {
+
+ ( @cur_row_ids{0,1} = @{$cur_row_data}[0,1] ),
+
+ ( $cur_row_ids{3} = (
+ ( ( defined $cur_row_data->[1] ) && (join "\xFF", q{}, $cur_row_ids{1}, q{} ))
+ or
+ "\0${rows_pos}\0"
+ )),
+
+ ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{3}} and (unshift @{$_[2]}, $cur_row_data) and last ),
+
+ # empty data for the root node
+ ( $collapse_idx[0]{$cur_row_ids{3}} //= $_[0][$result_pos++] = [] ),
+
+ ( ( ! defined $cur_row_data->[0] ) ? $collapse_idx[0]{$cur_row_ids{3}}[1]{"books"} = [] : do {
+ ( ! $collapse_idx[1]{$cur_row_ids{0}} )
+ and
+ push @{$collapse_idx[0]{$cur_row_ids{3}}[1]{books}},
+ $collapse_idx[1]{$cur_row_ids{0}} = [ { owner => $cur_row_data->[1], title => $cur_row_data->[0] } ]
+ } ),
+ }
+
+ $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results
+ ',
+ 'Non-premultiplied implicit collapse with missing join columns',
+);
+
done_testing;
my $deparser;
sub is_same_src { SKIP: {
+
+ skip "Skipping comparison of unicode-posioned source", 1
+ if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE;
+
$deparser ||= B::Deparse->new;
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ($got, $expect) = @_;
skip "Not testing equality of source containing defined-or operator on this perl $]", 1
- if ($] < 5.010 and$expect =~ m!\Q//=!);
+ if ( "$]" < 5.010 and $expect =~ m!\Q//=! );
- $expect =~ s/__NBC__/B::perlstring($DBIx::Class::ResultSource::RowParser::Util::null_branch_class)/ge;
+ $expect =~ s/__NBC__/perlstring($DBIx::Class::ResultSource::RowParser::Util::null_branch_class)/ge;
- $expect = " { use strict; use warnings FATAL => 'all';\n$expect\n }";
+ $expect = " { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }";
my @normalized = map {
my $cref = eval "sub { $_ }" or do {
use Test::More;
use Test::Exception;
+# MASSIVE FIXME - there is a hole in ::RSC / as_subselect_rs
+# losing the order. Needs a rework/extract of the realiaser,
+# and that's a whole another bag of dicks
+BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 }
+
+use DBIx::Class::_Util 'scope_guard';
+
use DBICTest::Schema::CD;
BEGIN {
# the default scalarref table name will not work well for this test
}
use DBICTest;
-use DBIC::DebugObj;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema;
-my ($sql, @bind);
-my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
-my $orig_debugobj = $schema->storage->debugobj;
-my $orig_debug = $schema->storage->debug;
-
my $tkfks = $schema->resultset('FourKeys_to_TwoKeys');
my ($fa, $fb, $fc) = $tkfks->related_resultset ('fourkeys')->populate ([
# [qw/2 2 /],
#]);
my ($ta, $tb) = $schema->resultset ('TwoKeys')
- ->search ( [ { artist => 1, cd => 1 }, { artist => 2, cd => 2 } ])
+ ->search ( [ { artist => 1, cd => 1 }, { artist => 2, cd => 2 } ], { order_by => 'artist' })
->all;
my $tkfk_cnt = $tkfks->count;
);
is ($fks->count, 4, 'Joined FourKey count correct (2x2)');
-
-$schema->storage->debugobj ($debugobj);
-$schema->storage->debug (1);
-$fks->update ({ read_count => \ 'read_count + 1' });
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
+$schema->is_executed_sql_bind( sub {
+ $fks->update ({ read_count => \ 'read_count + 1' })
+}, [[
'UPDATE fourkeys
SET read_count = read_count + 1
WHERE ( ( ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ) )
',
- [ ("'1'", "'2'") x 4, "'c'" ],
- 'Correct update-SQL with multijoin with pruning',
-);
+ (1, 2) x 4,
+ 'c',
+]], 'Correct update-SQL with multijoin with pruning' );
is ($fa->discard_changes->read_count, 11, 'Update ran only once on discard-join resultset');
is ($fb->discard_changes->read_count, 21, 'Update ran only once on discard-join resultset');
is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier');
# make the multi-join stick
-my $fks_multi = $fks->search({ 'fourkeys_to_twokeys.pilot_sequence' => { '!=' => 666 } });
-
-$schema->storage->debugobj ($debugobj);
-$schema->storage->debug (1);
-$fks_multi->update ({ read_count => \ 'read_count + 1' });
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
- 'UPDATE fourkeys
- SET read_count = read_count + 1
- WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )',
- [ map { "'$_'" } ( (1) x 4, (2) x 4 ) ],
- 'Correct update-SQL with multijoin without pruning',
+my $fks_multi = $fks->search(
+ { 'fourkeys_to_twokeys.pilot_sequence' => { '!=' => 666 } },
+ { order_by => [ $fks->result_source->primary_columns ] },
);
+$schema->is_executed_sql_bind( sub {
+ $fks_multi->update ({ read_count => \ 'read_count + 1' })
+}, [
+ [ 'BEGIN' ],
+ [
+ 'SELECT me.foo, me.bar, me.hello, me.goodbye
+ FROM fourkeys me
+ LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys
+ ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello
+ WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ?
+ GROUP BY me.foo, me.bar, me.hello, me.goodbye
+ ORDER BY foo, bar, hello, goodbye
+ ',
+ (1, 2) x 2,
+ 666,
+ (1, 2) x 2,
+ 'c',
+ ],
+ [
+ 'UPDATE fourkeys
+ SET read_count = read_count + 1
+ WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )
+ ',
+ ( (1) x 4, (2) x 4 ),
+ ],
+ [ 'COMMIT' ],
+], 'Correct update-SQL with multijoin without pruning' );
is ($fa->discard_changes->read_count, 12, 'Update ran only once on joined resultset');
is ($fb->discard_changes->read_count, 22, 'Update ran only once on joined resultset');
is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier');
+$schema->is_executed_sql_bind( sub {
+ my $res = $fks_multi->search (\' "blah" = "bleh" ')->delete;
+ ok ($res, 'operation is true');
+ cmp_ok ($res, '==', 0, 'zero rows affected');
+}, [
+ [ 'BEGIN' ],
+ [
+ 'SELECT me.foo, me.bar, me.hello, me.goodbye
+ FROM fourkeys me
+ LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys
+ ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello
+ WHERE "blah" = "bleh" AND ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ?
+ GROUP BY me.foo, me.bar, me.hello, me.goodbye
+ ORDER BY foo, bar, hello, goodbye
+ ',
+ (1, 2) x 2,
+ 666,
+ (1, 2) x 2,
+ 'c',
+ ],
+ [ 'COMMIT' ],
+], 'Correct null-delete-SQL with multijoin without pruning' );
+
+
# try the same sql with forced multicolumn in
-$schema->storage->_use_multicolumn_in (1);
-$schema->storage->debugobj ($debugobj);
-$schema->storage->debug (1);
-throws_ok { $fks_multi->update ({ read_count => \ 'read_count + 1' }) } # this can't actually execute, we just need the "as_query"
- qr/\QDBI Exception:/ or do { $sql = ''; @bind = () };
-$schema->storage->_use_multicolumn_in (undef);
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
+$schema->is_executed_sql_bind( sub {
+
+ my $orig_umi = $schema->storage->_use_multicolumn_in;
+ my $sg = scope_guard {
+ $schema->storage->_use_multicolumn_in($orig_umi);
+ };
+
+ $schema->storage->_use_multicolumn_in(1);
+
+ # this can't actually execute on sqlite
+ eval { $fks_multi->update ({ read_count => \ 'read_count + 1' }) };
+}, [[
'UPDATE fourkeys
SET read_count = read_count + 1
WHERE (
AND fourkeys_to_twokeys.f_foo = me.foo
AND fourkeys_to_twokeys.f_goodbye = me.goodbye
AND fourkeys_to_twokeys.f_hello = me.hello
- WHERE fourkeys_to_twokeys.pilot_sequence != ? AND ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ?
+ WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ?
+ ORDER BY foo, bar, hello, goodbye
)
)
',
+ ( 1, 2) x 2,
+ 666,
+ ( 1, 2) x 2,
+ 'c',
+]], 'Correct update-SQL with multicolumn in support' );
+
+$schema->is_executed_sql_bind( sub {
+ $fks->search({ 'twokeys.artist' => { '!=' => 666 } })->update({ read_count => \ 'read_count + 1' });
+}, [
+ [ 'BEGIN' ],
[
- "'666'",
- ("'1'", "'2'") x 4,
- "'c'",
+ 'SELECT me.foo, me.bar, me.hello, me.goodbye
+ FROM fourkeys me
+ LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys
+ ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello
+ LEFT JOIN twokeys twokeys
+ ON twokeys.artist = fourkeys_to_twokeys.t_artist AND twokeys.cd = fourkeys_to_twokeys.t_cd
+ WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? AND twokeys.artist != ?
+ GROUP BY me.foo, me.bar, me.hello, me.goodbye
+ ',
+ (1, 2) x 4,
+ 'c',
+ 666,
],
- 'Correct update-SQL with multicolumn in support',
-);
-
-# make a *premultiplied* join stick
-my $fks_premulti = $fks->search({ 'twokeys.artist' => { '!=' => 666 } });
-
-$schema->storage->debugobj ($debugobj);
-$schema->storage->debug (1);
-$fks_premulti->update ({ read_count => \ 'read_count + 1' });
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
- 'UPDATE fourkeys
- SET read_count = read_count + 1
- WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )',
- [ map { "'$_'" } ( (1) x 4, (2) x 4 ) ],
- 'Correct update-SQL with premultiplied restricting join without pruning',
-);
+ [
+ 'UPDATE fourkeys
+ SET read_count = read_count + 1
+ WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )
+ ',
+ ( (1) x 4, (2) x 4 ),
+ ],
+ [ 'COMMIT' ],
+], 'Correct update-SQL with premultiplied restricting join without pruning' );
is ($fa->discard_changes->read_count, 13, 'Update ran only once on joined resultset');
is ($fb->discard_changes->read_count, 23, 'Update ran only once on joined resultset');
is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier');
-
#
# Make sure multicolumn in or the equivalent functions correctly
#
$tkfks->search ({}, { rows => 1 })->delete;
is ($tkfks->count, $tkfk_cnt -= 1, 'Only one row deleted');
+throws_ok {
+ $tkfks->search ({}, { rows => 0 })->delete
+} qr/rows attribute must be a positive integer/;
+is ($tkfks->count, $tkfk_cnt, 'Nothing deleted');
# check with sql-equality, as sqlite will accept most bad sql just fine
-$schema->storage->debugobj ($debugobj);
-$schema->storage->debug (1);
-
{
my $rs = $schema->resultset('CD')->search(
{ 'me.year' => { '!=' => 2010 } },
);
- $rs->search({}, { join => 'liner_notes' })->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $rs->search({}, { join => 'liner_notes' })->delete;
+ }, [[
'DELETE FROM cd WHERE ( year != ? )',
- ["'2010'"],
- 'Non-restricting multijoins properly thrown out'
- );
+ 2010,
+ ]], 'Non-restricting multijoins properly thrown out' );
- $rs->search({}, { prefetch => 'liner_notes' })->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $rs->search({}, { prefetch => 'liner_notes' })->delete;
+ }, [[
'DELETE FROM cd WHERE ( year != ? )',
- ["'2010'"],
- 'Non-restricting multiprefetch thrown out'
- );
+ 2010,
+ ]], 'Non-restricting multiprefetch thrown out' );
- $rs->search({}, { prefetch => 'artist' })->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $rs->search({}, { prefetch => 'artist' })->delete;
+ }, [[
'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )',
- ["'2010'"],
- 'Restricting prefetch left in, selector thrown out'
- );
+ 2010,
+ ]], 'Restricting prefetch left in, selector thrown out');
- # switch artist and cd to fully qualified table names
- # make sure nothing is stripped out
+### switch artist and cd to fully qualified table names
+### make sure nothing is stripped out
my $cd_rsrc = $schema->source('CD');
$cd_rsrc->name('main.cd');
$cd_rsrc->relationship_info($_)->{attrs}{cascade_delete} = 0
$art_rsrc->relationship_info($_)->{attrs}{cascade_delete} = 0
for $art_rsrc->relationships;
- $rs->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
- 'DELETE FROM main.cd WHERE ( year != ? )',
- ["'2010'"],
- 'delete with fully qualified table name'
- );
+ $schema->is_executed_sql_bind( sub {
+ $rs->delete
+ }, [[
+ 'DELETE FROM main.cd WHERE year != ?',
+ 2010,
+ ]], 'delete with fully qualified table name' );
$rs->create({ title => 'foo', artist => 1, year => 2000 });
- $rs->delete_all;
- is_same_sql_bind (
- $sql,
- \@bind,
- 'DELETE FROM main.cd WHERE ( cdid = ? )',
- ["'1'"],
- 'delete_all with fully qualified table name'
- );
-
- $rs->create({ cdid => 42, title => 'foo', artist => 2, year => 2000 });
- $rs->find(42)->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
- 'DELETE FROM main.cd WHERE ( cdid = ? )',
- ["'42'"],
- 'delete of object from table with fully qualified name'
- );
+ $schema->is_executed_sql_bind( sub {
+ $rs->delete_all
+ }, [
+ [ 'BEGIN' ],
+ [
+ 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM main.cd me WHERE me.year != ?',
+ 2010,
+ ],
+ [
+ 'DELETE FROM main.cd WHERE ( cdid = ? )',
+ 1,
+ ],
+ [ 'COMMIT' ],
+ ], 'delete_all with fully qualified table name' );
$rs->create({ cdid => 42, title => 'foo', artist => 2, year => 2000 });
- $rs->find(42)->related_resultset('artist')->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ my $cd42 = $rs->find(42);
+
+ $schema->is_executed_sql_bind( sub {
+ $cd42->delete
+ }, [[
+ 'DELETE FROM main.cd WHERE cdid = ?',
+ 42,
+ ]], 'delete of object from table with fully qualified name' );
+
+ $schema->is_executed_sql_bind( sub {
+ $cd42->related_resultset('artist')->delete
+ }, [[
'DELETE FROM main.artist WHERE ( artistid IN ( SELECT me.artistid FROM main.artist me WHERE ( me.artistid = ? ) ) )',
- ["'2'"],
- 'delete of related object from scalarref fully qualified named table',
- );
+ 2,
+ ]], 'delete of related object from scalarref fully qualified named table' );
- $schema->resultset('Artist')->find(3)->related_resultset('cds')->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ my $art3 = $schema->resultset('Artist')->find(3);
+
+ $schema->is_executed_sql_bind( sub {
+ $art3->related_resultset('cds')->delete;
+ }, [[
'DELETE FROM main.cd WHERE ( artist = ? )',
- ["'3'"],
- 'delete of related object from fully qualified named table',
- );
+ 3,
+ ]], 'delete of related object from fully qualified named table' );
- $schema->resultset('Artist')->find(3)->cds_unordered->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $art3->cds_unordered->delete;
+ }, [[
'DELETE FROM main.cd WHERE ( artist = ? )',
- ["'3'"],
- 'delete of related object from fully qualified named table via relaccessor',
- );
+ 3,
+ ]], 'delete of related object from fully qualified named table via relaccessor' );
- $rs->search({}, { prefetch => 'artist' })->delete;
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $rs->search({}, { prefetch => 'artist' })->delete;
+ }, [[
'DELETE FROM main.cd WHERE ( cdid IN ( SELECT me.cdid FROM main.cd me JOIN main.artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )',
- ["'2010'"],
- 'delete with fully qualified table name and subquery correct'
- );
+ 2010,
+ ]], 'delete with fully qualified table name and subquery correct' );
# check that as_subselect_rs works ok
# inner query is untouched, then a selector
# and an IN condition
- $schema->resultset('CD')->search({
- 'me.cdid' => 1,
- 'artist.name' => 'partytimecity',
- }, {
- join => 'artist',
- })->as_subselect_rs->delete;
-
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ $schema->resultset('CD')->search({
+ 'me.cdid' => 1,
+ 'artist.name' => 'partytimecity',
+ }, {
+ join => 'artist',
+ })->as_subselect_rs->delete;
+ }, [[
'
DELETE FROM main.cd
WHERE (
)
)
',
- ["'partytimecity'", "'1'"],
- 'Delete from as_subselect_rs works correctly'
- );
+ 'partytimecity',
+ 1,
+ ]], 'Delete from as_subselect_rs works correctly' );
}
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib 't/lib';
+use DBICTest;
+
+{
+ package DBICTest::Foo;
+ use base "DBIx::Class::Core";
+}
+
+throws_ok { DBICTest::Foo->new("urgh") } qr/must be a hashref/;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd = $schema->resultset('CD')->search({}, {
+ '+columns' => { avg_year => $schema->resultset('CD')->get_column('year')->func_rs('avg')->as_query },
+ order_by => 'cdid',
+})->next;
+
+my $ccd = $cd->copy({ cdid => 5_000_000, artist => 2 });
+
+cmp_ok(
+ $ccd->id,
+ '!=',
+ $cd->id,
+ 'IDs differ'
+);
+
+is(
+ $ccd->title,
+ $cd->title,
+ 'Title same on copied object',
+);
+
+done_testing;
my $from_storage_ran = 0;
my $to_storage_ran = 0;
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( no_populate => 1 );
DBICTest::Schema::Artist->load_components(qw(FilterColumn InflateColumn));
-DBICTest::Schema::Artist->filter_column(rank => {
- filter_from_storage => sub { $from_storage_ran++; $_[1] * 2 },
- filter_to_storage => sub { $to_storage_ran++; $_[1] / 2 },
+DBICTest::Schema::Artist->filter_column(charfield => {
+ filter_from_storage => sub { $from_storage_ran++; defined $_[1] ? $_[1] * 2 : undef },
+ filter_to_storage => sub { $to_storage_ran++; defined $_[1] ? $_[1] / 2 : undef },
});
-Class::C3->reinitialize();
+Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
-my $artist = $schema->resultset('Artist')->create( { rank => 20 } );
+my $artist = $schema->resultset('Artist')->create( { charfield => 20 } );
# this should be using the cursor directly, no inflation/processing of any sort
-my ($raw_db_rank) = $schema->resultset('Artist')
+my ($raw_db_charfield) = $schema->resultset('Artist')
->search ($artist->ident_condition)
- ->get_column('rank')
+ ->get_column('charfield')
->_resultset
->cursor
->next;
-is ($raw_db_rank, 10, 'INSERT: correctly unfiltered on insertion');
+is ($raw_db_charfield, 10, 'INSERT: correctly unfiltered on insertion');
for my $reloaded (0, 1) {
my $test = $reloaded ? 'reloaded' : 'stored';
$artist->discard_changes if $reloaded;
- is( $artist->rank , 20, "got $test filtered rank" );
+ is( $artist->charfield , 20, "got $test filtered charfield" );
}
$artist->update;
$artist->discard_changes;
-is( $artist->rank , 20, "got filtered rank" );
+is( $artist->charfield , 20, "got filtered charfield" );
-$artist->update ({ rank => 40 });
-($raw_db_rank) = $schema->resultset('Artist')
+$artist->update ({ charfield => 40 });
+($raw_db_charfield) = $schema->resultset('Artist')
->search ($artist->ident_condition)
- ->get_column('rank')
+ ->get_column('charfield')
->_resultset
->cursor
->next;
-is ($raw_db_rank, 20, 'UPDATE: correctly unflitered on update');
+is ($raw_db_charfield, 20, 'UPDATE: correctly unflitered on update');
$artist->discard_changes;
-$artist->rank(40);
-ok( !$artist->is_column_changed('rank'), 'column is not dirty after setting the same value' );
+$artist->charfield(40);
+ok( !$artist->is_column_changed('charfield'), 'column is not dirty after setting the same value' );
MC: {
my $cd = $schema->resultset('CD')->create({
- artist => { rank => 20 },
+ artist => { charfield => 20 },
title => 'fun time city!',
year => 'forevertime',
});
- ($raw_db_rank) = $schema->resultset('Artist')
+ ($raw_db_charfield) = $schema->resultset('Artist')
->search ($cd->artist->ident_condition)
- ->get_column('rank')
+ ->get_column('charfield')
->_resultset
->cursor
->next;
- is $raw_db_rank, 10, 'artist rank gets correctly unfiltered w/ MC';
- is $cd->artist->rank, 20, 'artist rank gets correctly filtered w/ MC';
+ is $raw_db_charfield, 10, 'artist charfield gets correctly unfiltered w/ MC';
+ is $cd->artist->charfield, 20, 'artist charfield gets correctly filtered w/ MC';
}
CACHE_TEST: {
is $from_storage_ran, $expected_from, 'from has not run yet';
is $to_storage_ran, $expected_to, 'to has not run yet';
- $artist->rank;
+ $artist->charfield;
cmp_ok (
- $artist->get_filtered_column('rank'),
+ $artist->get_filtered_column('charfield'),
'!=',
- $artist->get_column('rank'),
+ $artist->get_column('charfield'),
'filter/unfilter differ'
);
is $from_storage_ran, ++$expected_from, 'from ran once, therefor caches';
is $to_storage_ran, $expected_to, 'to did not run';
- $artist->rank(6);
+ $artist->charfield(6);
is $from_storage_ran, $expected_from, 'from did not run';
is $to_storage_ran, ++$expected_to, 'to ran once';
- ok ($artist->is_column_changed ('rank'), 'Column marked as dirty');
+ ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty');
- $artist->rank;
+ $artist->charfield;
is $from_storage_ran, $expected_from, 'from did not run';
is $to_storage_ran, $expected_to, 'to did not run';
$artist->update;
- $artist->set_column(rank => 3);
- ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same set_column value');
- is ($artist->rank, '6', 'Column set properly (cache blown)');
+ $artist->set_column(charfield => 3);
+ ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on same set_column value');
+ is ($artist->charfield, '6', 'Column set properly (cache blown)');
is $from_storage_ran, ++$expected_from, 'from ran once (set_column blew cache)';
is $to_storage_ran, $expected_to, 'to did not run';
- $artist->rank(6);
- ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same accessor-set value');
- is ($artist->rank, '6', 'Column set properly');
+ $artist->charfield(6);
+ ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on same accessor-set value');
+ is ($artist->charfield, '6', 'Column set properly');
is $from_storage_ran, $expected_from, 'from did not run';
- is $to_storage_ran, $expected_to, 'to did not run';
+ is $to_storage_ran, ++$expected_to, 'to did run once (call in to set_column)';
- $artist->store_column(rank => 4);
- ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on differing store_column value');
- is ($artist->rank, '8', 'Cache properly blown');
+ $artist->store_column(charfield => 4);
+ ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on differing store_column value');
+ is ($artist->charfield, '8', 'Cache properly blown');
is $from_storage_ran, ++$expected_from, 'from did not run';
is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->update({ charfield => undef });
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, ++$expected_to, 'to did run';
+
+ $artist->discard_changes;
+ is ( $artist->get_column('charfield'), undef, 'Got back null' );
+ is ( $artist->charfield, undef, 'Got back null through filter' );
+
+ is $from_storage_ran, ++$expected_from, 'from did run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+}
+
+# test in-memory operations
+for my $artist_maker (
+ sub { $schema->resultset('Artist')->new({ charfield => 42 }) },
+ sub { my $art = $schema->resultset('Artist')->new({}); $art->charfield(42); $art },
+) {
+
+ my $expected_from = $from_storage_ran;
+ my $expected_to = $to_storage_ran;
+
+ my $artist = $artist_maker->();
+
+ is $from_storage_ran, $expected_from, 'from has not run yet';
+ is $to_storage_ran, $expected_to, 'to has not run yet';
+
+ ok( ! $artist->has_column_loaded('artistid'), 'pk not loaded' );
+ ok( $artist->has_column_loaded('charfield'), 'Filtered column marked as loaded under new' );
+ is( $artist->charfield, 42, 'Proper unfiltered value' );
+ is( $artist->get_column('charfield'), 21, 'Proper filtered value' );
+}
+
+# test literals
+for my $v ( \ '16', \[ '?', '16' ] ) {
+ my $rs = $schema->resultset('Artist');
+ $rs->delete;
+
+ my $art = $rs->new({ charfield => 10 });
+ $art->charfield($v);
+
+ is_deeply( $art->charfield, $v);
+ is_deeply( $art->get_filtered_column("charfield"), $v);
+ is_deeply( $art->get_column("charfield"), $v);
+
+ $art->insert;
+ $art->discard_changes;
+
+ is ($art->get_column("charfield"), 16, "Literal inserted into database properly");
+ is ($art->charfield, 32, "filtering still works");
+
+ $art->update({ charfield => $v });
+
+ is_deeply( $art->charfield, $v);
+ is_deeply( $art->get_filtered_column("charfield"), $v);
+ is_deeply( $art->get_column("charfield"), $v);
+
+ $art->discard_changes;
+
+ is ($art->get_column("charfield"), 16, "Literal inserted into database properly");
+ is ($art->charfield, 32, "filtering still works");
}
IC_DIE: {
- dies_ok {
- DBICTest::Schema::Artist->inflate_column(rank =>
+ throws_ok {
+ DBICTest::Schema::Artist->inflate_column(charfield =>
{ inflate => sub {}, deflate => sub {} }
);
- } q(Can't inflate column after filter column);
+ } qr/InflateColumn can not be used on a column with a declared FilterColumn filter/, q(Can't inflate column after filter column);
DBICTest::Schema::Artist->inflate_column(name =>
{ inflate => sub {}, deflate => sub {} }
);
- dies_ok {
+ throws_ok {
DBICTest::Schema::Artist->filter_column(name => {
filter_to_storage => sub {},
filter_from_storage => sub {}
});
- } q(Can't filter column after inflate column);
+ } qr/FilterColumn can not be used on a column with a declared InflateColumn inflator/, q(Can't filter column after inflate column);
}
# test when we do not set both filter_from_storage/filter_to_storage
-DBICTest::Schema::Artist->filter_column(rank => {
+DBICTest::Schema::Artist->filter_column(charfield => {
filter_to_storage => sub { $to_storage_ran++; $_[1] },
});
-Class::C3->reinitialize();
+Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
ASYMMETRIC_TO_TEST: {
# initialise value
- $artist->rank(20);
+ $artist->charfield(20);
$artist->update;
my $expected_from = $from_storage_ran;
my $expected_to = $to_storage_ran;
- $artist->rank(10);
- ok ($artist->is_column_changed ('rank'), 'Column marked as dirty on accessor-set value');
- is ($artist->rank, '10', 'Column set properly');
+ $artist->charfield(10);
+ ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty on accessor-set value');
+ is ($artist->charfield, '10', 'Column set properly');
is $from_storage_ran, $expected_from, 'from did not run';
is $to_storage_ran, ++$expected_to, 'to did run';
$artist->discard_changes;
- is ($artist->rank, '20', 'Column set properly');
+ is ($artist->charfield, '20', 'Column set properly');
is $from_storage_ran, $expected_from, 'from did not run';
is $to_storage_ran, $expected_to, 'to did not run';
}
-DBICTest::Schema::Artist->filter_column(rank => {
+DBICTest::Schema::Artist->filter_column(charfield => {
filter_from_storage => sub { $from_storage_ran++; $_[1] },
});
-Class::C3->reinitialize();
+Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
ASYMMETRIC_FROM_TEST: {
# initialise value
- $artist->rank(23);
+ $artist->charfield(23);
$artist->update;
my $expected_from = $from_storage_ran;
my $expected_to = $to_storage_ran;
- $artist->rank(13);
- ok ($artist->is_column_changed ('rank'), 'Column marked as dirty on accessor-set value');
- is ($artist->rank, '13', 'Column set properly');
+ $artist->charfield(13);
+ ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty on accessor-set value');
+ is ($artist->charfield, '13', 'Column set properly');
is $from_storage_ran, $expected_from, 'from did not run';
is $to_storage_ran, $expected_to, 'to did not run';
$artist->discard_changes;
- is ($artist->rank, '23', 'Column set properly');
+ is ($artist->charfield, '23', 'Column set properly');
is $from_storage_ran, ++$expected_from, 'from did run';
is $to_storage_ran, $expected_to, 'to did not run';
}
-throws_ok { DBICTest::Schema::Artist->filter_column( rank => {} ) }
+throws_ok { DBICTest::Schema::Artist->filter_column( charfield => {} ) }
qr/\QAn invocation of filter_column() must specify either a filter_from_storage or filter_to_storage/,
'Correctly throws exception for empty attributes'
;
+FC_ON_PK_TEST: {
+ # there are cases in the wild that autovivify stuff deep in the
+ # colinfo guts. While this is insane, there is no alternative
+ # so at leats make sure it keeps working...
+
+ $schema->source('Artist')->column_info('artistid')->{_filter_info} ||= {};
+
+ for my $key ('', 'primary') {
+ lives_ok {
+ $schema->resultset('Artist')->find_or_create({ artistid => 42 }, { $key ? ( key => $key ) : () });
+ };
+ }
+
+
+ DBICTest::Schema::Artist->filter_column(artistid => {
+ filter_to_storage => sub { $_[1] * 100 },
+ filter_from_storage => sub { $_[1] - 100 },
+ });
+
+ for my $key ('', 'primary') {
+ throws_ok {
+ $schema->resultset('Artist')->find_or_create({ artistid => 42 }, { $key ? ( key => $key ) : () });
+ } qr/\QUnable to satisfy requested constraint 'primary', FilterColumn values not usable for column(s): 'artistid'/;
+ }
+}
+
done_testing;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 });
my $cd = $artist->create_related('cds', { year => 1975, title => 'Compilation from 1975' });
-my ($sql, @bind);
-local $schema->storage->{debug} = 1;
-local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
-
-my $find_cd = $artist->find_related('cds',{title => 'Compilation from 1975'});
-
-s/^'//, s/'\z// for @bind; # why does DBIC::DebugObj not do this?
-
-is_same_sql_bind (
- $sql,
- \@bind,
- 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( me.artist = ? AND me.title = ? ) ) ORDER BY year ASC',
- [21, 'Compilation from 1975'],
- 'find_related only uses foreign key condition once',
-);
+$schema->is_executed_sql_bind(sub {
+ my $find_cd = $artist->find_related('cds',{title => 'Compilation from 1975'});
+}, [
+ [
+ ' SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ WHERE me.artist = ? AND me.title = ?
+ ORDER BY year ASC
+ ',
+ [ { dbic_colname => "me.artist", sqlt_datatype => "integer" }
+ => 21 ],
+ [ { dbic_colname => "me.title", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => "Compilation from 1975" ],
+ ]
+], 'find_related only uses foreign key condition once' );
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $rs_with_avg = $schema->resultset('CD')->search({}, {
+ '+columns' => { avg_year => $schema->resultset('CD')->get_column('year')->func_rs('avg')->as_query },
+ order_by => 'cdid',
+});
+
+for my $in_storage (1, 0) {
+ my $cd = $rs_with_avg->first;
+
+ ok ! $cd->is_column_changed('avg_year'), 'no changes';
+
+ $cd->in_storage($in_storage);
+
+ ok ! $cd->is_column_changed('avg_year'), 'still no changes';
+
+ $cd->set_column( avg_year => 42 );
+ $cd->set_column( avg_year => 69 );
+
+ ok $cd->is_column_changed('avg_year'), 'changed';
+ is $cd->get_column('avg_year'), 69, 'correct value'
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $row = DBICTest::Schema::CD->new({ title => 'foo' });
+
+my @values = qw( foo bar baz );
+for my $i ( 0 .. $#values ) {
+ {
+ local $TODO = 'This probably needs to always return 1, on virgin objects... same with get_dirty_columns'
+ unless $i;
+
+ ok ( $row->is_column_changed('title'), 'uninserted row properly reports "eternally changed" value' );
+ is_deeply (
+ { $row->get_dirty_columns },
+ { title => $values[$i-1] },
+ 'uninserted row properly reports "eternally changed" dirty_columns()'
+ );
+ }
+
+ $row->title( $values[$i] );
+
+ ok( $row->is_column_changed('title'), 'uninserted row properly reports changed value' );
+ is( $row->title, $values[$i] , 'Expected value on sourceless row' );
+ for my $meth (qw( get_columns get_inflated_columns get_dirty_columns )) {
+ is_deeply(
+ { $row->$meth },
+ { title => $values[$i] },
+ "Expected '$meth' rv",
+ )
+ }
+}
+
+done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest ':DiffSQL';
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('Artist')->search(
+ [ -and => [ {}, [] ], -or => [ {}, [] ] ],
+ {
+ select => [],
+ columns => {},
+ '+columns' => 'artistid',
+ join => [ {}, [ [ {}, {} ] ], {} ],
+ prefetch => [ [ [ {}, [] ], {} ], {}, [ {} ] ],
+ order_by => [],
+ group_by => [],
+ offset => 0,
+ }
+);
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(SELECT me.artistid FROM artist me)',
+ [],
+);
+
+is_same_sql_bind(
+ $rs->count_rs->as_query,
+ '(SELECT COUNT(*) FROM artist me)',
+ [],
+);
+
+is_same_sql_bind(
+ $rs->as_subselect_rs->search({}, { columns => 'artistid' })->as_query,
+ '(SELECT me.artistid FROM (SELECT me.artistid FROM artist me) me)',
+ [],
+);
+
+{
+ local $TODO = 'Stupid misdesigned as_subselect_rs';
+ is_same_sql_bind(
+ $rs->as_subselect_rs->as_query,
+ $rs->as_subselect_rs->search({}, { columns => 'artistid' })->as_query,
+ );
+}
+
+done_testing;
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
-
-use Storable qw/dclone/;
+use DBICTest ':DiffSQL';
+use DBIx::Class::_Util 'serialize';
my $schema = DBICTest->init_schema();
# A search() with prefetch seems to pollute an already joined resultset
# in a way that offsets future joins (adapted from a test case by Debolaz)
{
- my ($cd_rs, $attrs);
+ my ($cd_rs, $preimage);
# test a real-life case - rs is obtained by an implicit m2m join
$cd_rs = $schema->resultset ('Producer')->first->cds;
- $attrs = dclone( $cd_rs->{attrs} );
+ $preimage = serialize $cd_rs->{attrs};
$cd_rs->search ({})->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after a simple search');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after search with prefetch');
}, 'first prefetching search ok');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after another search with prefetch')
}, 'second prefetching search ok');
# test a regular rs with an empty seen_join injected - it should still work!
$cd_rs = $schema->resultset ('CD');
$cd_rs->{attrs}{seen_join} = {};
- $attrs = dclone( $cd_rs->{attrs} );
+ $preimage = serialize $cd_rs->{attrs};
$cd_rs->search ({})->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after a simple search');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after search with prefetch');
}, 'first prefetching search ok');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after another search with prefetch')
}, 'second prefetching search ok');
}
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest ':DiffSQL';
+use SQL::Abstract qw(is_plain_value is_literal_value);
+use List::Util 'shuffle';
+use Data::Dumper;
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Useqq = 1;
+$Data::Dumper::Indent = 0;
+
+my $schema = DBICTest->init_schema();
+
+for my $c (
+ { cond => undef, sql => 'IS NULL' },
+ { cond => { -value => undef }, sql => 'IS NULL' },
+ { cond => \'foo', sql => '= foo' },
+ { cond => 'foo', sql => '= ?', bind => [
+ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ],
+ [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ],
+ ]},
+ { cond => { -value => 'foo' }, sql => '= ?', bind => [
+ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ],
+ [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ],
+ ]},
+ { cond => \[ '?', "foo" ], sql => '= ?', bind => [
+ [ {} => 'foo' ],
+ [ {} => 'foo' ],
+ ]},
+) {
+ my $rs = $schema->resultset('CD')->search({}, { columns => 'title' });
+
+ my $bare_cond = is_literal_value($c->{cond}) ? { '=', $c->{cond} } : $c->{cond};
+
+ my @query_steps = (
+ # these are monkey-wrenches, always there
+ { title => { '!=', [ -and => \'bar' ] }, year => { '!=', [ -and => 'bar' ] } },
+ { -or => [ genreid => undef, genreid => { '!=' => \42 } ] },
+ { -or => [ genreid => undef, genreid => { '!=' => \42 } ] },
+
+ { title => $bare_cond, year => { '=', $c->{cond} } },
+ { -and => [ year => $bare_cond, { title => { '=', $c->{cond} } } ] },
+ [ year => $bare_cond ],
+ [ title => $bare_cond ],
+ { -and => [ { year => { '=', $c->{cond} } }, { title => { '=', $c->{cond} } } ] },
+ { -and => { -or => { year => { '=', $c->{cond} } } }, -or => { title => $bare_cond } },
+ );
+
+ if (my $v = is_plain_value($c->{cond})) {
+ push @query_steps,
+ { year => $$v },
+ { title => $$v },
+ { -and => [ year => $$v, title => $$v ] },
+ ;
+ }
+
+ @query_steps = shuffle @query_steps;
+
+ $rs = $rs->search($_) for @query_steps;
+
+ my @bind = @{$c->{bind} || []};
+ {
+ no warnings 'misc';
+ splice @bind, 1, 0, [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'bar' ];
+ }
+
+ is_same_sql_bind (
+ $rs->as_query,
+ "(
+ SELECT me.title
+ FROM cd me
+ WHERE
+ ( genreid != 42 OR genreid IS NULL )
+ AND
+ ( genreid != 42 OR genreid IS NULL )
+ AND
+ title != bar
+ AND
+ title $c->{sql}
+ AND
+ year != ?
+ AND
+ year $c->{sql}
+ )",
+ \@bind,
+ 'Double condition correctly collapsed for steps' . Dumper \@query_steps,
+ );
+}
+
+done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
+use DBIx::Class::_Util 'sigwarn_silencer';
my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
for my $i (0 .. $#tests) {
my $t = $tests[$i];
for my $p (1, 2) { # repeat everything twice, make sure we do not clobber search arguments
+ local $SIG{__WARN__} = sigwarn_silencer( qr/\Q{from} structures with conditions not conforming to the SQL::Abstract syntax are deprecated/ );
+
is_same_sql_bind (
$t->{rs}->search ($t->{search}, $t->{attrs})->as_query,
$t->{sqlbind},
use Math::BigInt;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($ROWS, $OFFSET) = (
'stringifyable $object === [ {}, $object ]',
);
-throws_ok {
- shorthand_check(
+shorthand_check(
[ 2 ],
- [],
- )
-} qr !You must supply a datatype/bindtype .+ for non-scalar value \Q[ 2 ]!,
- 'exception on bare array bindvalue';
+ [ {} => [ 2 ] ],
+);
-throws_ok {
- shorthand_check(
+shorthand_check(
[ {} => [ 2 ] ],
- [],
- )
-} qr !You must supply a datatype/bindtype .+ for non-scalar value \Q[ 2 ]!,
- 'exception on untyped array bindvalue';
+ [ {} => [ 2 ] ],
+);
-throws_ok {
- shorthand_check(
+shorthand_check(
[ {}, 2, 3 ],
- [],
- )
-} qr !You must supply a datatype/bindtype .+ for non-scalar value \[ 'HASH\(\w+\)', 2, 3 \]!,
- 'exception on bare multielement array bindvalue';
+ [ {} => [ {}, 2, 3 ] ],
+);
-throws_ok {
- shorthand_check(
+shorthand_check(
bless( {}, 'Foo'),
- [],
- )
-} qr !You must supply a datatype/bindtype .+ for non-scalar value \Qbless( {}, 'Foo' )!,
- 'exception on bare object';
+ [ {} => bless( {}, 'Foo') ],
+);
-throws_ok {
- shorthand_check(
+shorthand_check(
+ [ {}, bless( {}, 'Foo') ],
[ {}, bless( {}, 'Foo') ],
- [],
- )
-} qr !You must supply a datatype/bindtype .+ for non-scalar value \Qbless( {}, 'Foo' )!,
- 'exception on untyped object';
+);
sub shorthand_check {
use Test::Exception;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema(no_deploy => 1);
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
'-join_type' => ''
},
{
- 'artist.artistid' => 'me.artist'
+ 'artist.artistid' => { -ident => 'me.artist' },
}
],
[
'-join_type' => 'left'
},
{
- 'tracks.cd' => 'me.cdid'
+ 'tracks.cd' => { -ident => 'me.cdid' },
}
],
],
'-join_type' => ''
},
{
- 'artist.artistid' => 'me.artist'
+ 'artist.artistid' => { -ident => 'me.artist' }
}
]
],
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest ':DiffSQL';
+use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION';
+
+use Data::Dumper;
+BEGIN {
+ if ( eval { require Test::Differences } ) {
+ no warnings 'redefine';
+ *is_deeply = \&Test::Differences::eq_or_diff;
+ }
+}
+
+my $schema = DBICTest->init_schema( no_deploy => 1);
+my $sm = $schema->storage->sql_maker;
+
+{
+ package # hideee
+ DBICTest::SillyInt;
+
+ use overload
+ fallback => 1,
+ '0+' => sub { ${$_[0]} },
+ ;
+}
+my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt' );
+
+is($num, 69, 'test overloaded object is "sane"');
+is("$num", 69, 'test overloaded object is "sane"');
+
+my @tests = (
+ {
+ where => { artistid => 1, charfield => undef },
+ cc_result => { artistid => 1, charfield => undef },
+ sql => 'WHERE artistid = ? AND charfield IS NULL',
+ efcc_result => { artistid => 1 },
+ efcc_n_result => { artistid => 1, charfield => undef },
+ },
+ {
+ where => { -and => [ artistid => 1, charfield => undef, { rank => 13 } ] },
+ cc_result => { artistid => 1, charfield => undef, rank => 13 },
+ sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?',
+ efcc_result => { artistid => 1, rank => 13 },
+ efcc_n_result => { artistid => 1, charfield => undef, rank => 13 },
+ },
+ {
+ where => { -and => [ { artistid => 1, charfield => undef}, { rank => 13 } ] },
+ cc_result => { artistid => 1, charfield => undef, rank => 13 },
+ sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?',
+ efcc_result => { artistid => 1, rank => 13 },
+ efcc_n_result => { artistid => 1, charfield => undef, rank => 13 },
+ },
+ {
+ where => { -and => [ -or => { name => 'Caterwauler McCrae' }, 'rank' ] },
+ cc_result => { name => 'Caterwauler McCrae', rank => undef },
+ sql => 'WHERE name = ? AND rank IS NULL',
+ efcc_result => { name => 'Caterwauler McCrae' },
+ efcc_n_result => { name => 'Caterwauler McCrae', rank => undef },
+ },
+ {
+ where => { -and => [ [ [ artist => {'=' => \'foo' } ] ], { name => \[ '= ?', 'bar' ] } ] },
+ cc_result => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] },
+ sql => 'WHERE artist = foo AND name = ?',
+ efcc_result => { artist => \'foo' },
+ },
+ {
+ where => { -and => [ -or => { name => 'Caterwauler McCrae', artistid => 2 } ] },
+ cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] },
+ sql => 'WHERE artistid = ? OR name = ?',
+ efcc_result => {},
+ },
+ {
+ where => { -or => { name => 'Caterwauler McCrae', artistid => 2 } },
+ cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] },
+ sql => 'WHERE artistid = ? OR name = ?',
+ efcc_result => {},
+ },
+ {
+ where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'} ] },
+ cc_result => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num },
+ sql => 'WHERE foo=bar AND artistid = ? AND name = ?',
+ efcc_result => { name => 'Caterwauler McCrae', artistid => $num },
+ },
+ {
+ where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] },
+ cc_result => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num },
+ sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz',
+ collapsed_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?',
+ efcc_result => { name => 'Caterwauler McCrae', artistid => $num },
+ },
+ {
+ where => { artistid => [ $num ], rank => [ 13, 2, 3 ], charfield => [ undef ] },
+ cc_result => { artistid => $num, charfield => undef, rank => [13, 2, 3] },
+ sql => 'WHERE artistid = ? AND charfield IS NULL AND ( rank = ? OR rank = ? OR rank = ? )',
+ efcc_result => { artistid => $num },
+ efcc_n_result => { artistid => $num, charfield => undef },
+ },
+ {
+ where => { artistid => { '=' => 1 }, rank => { '>' => 12 }, charfield => { '=' => undef } },
+ cc_result => { artistid => 1, charfield => undef, rank => { '>' => 12 } },
+ sql => 'WHERE artistid = ? AND charfield IS NULL AND rank > ?',
+ efcc_result => { artistid => 1 },
+ efcc_n_result => { artistid => 1, charfield => undef },
+ },
+ {
+ where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } },
+ cc_result => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } },
+ sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )',
+ collapsed_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )',
+ efcc_result => { artistid => 1, charfield => UNRESOLVABLE_CONDITION },
+ },
+ {
+ where => { -and => [ artistid => 1, artistid => 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => [ -or => { '=', 2 } ], rank => [-and => undef, { '=', undef }, { '!=', 2 } ] },
+ cc_result => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] },
+ sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?',
+ collapsed_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL',
+ efcc_result => {
+ artistid => UNRESOLVABLE_CONDITION,
+ name => 2,
+ charfield => 2,
+ },
+ efcc_n_result => {
+ artistid => UNRESOLVABLE_CONDITION,
+ name => 2,
+ charfield => 2,
+ rank => undef,
+ },
+ },
+ (map { {
+ where => $_,
+ sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)',
+ collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)',
+ cc_result => { -and => [
+ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
+ { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] },
+ ] },
+ efcc_result => {},
+ efcc_n_result => {},
+ } } (
+
+ { -and => [
+ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
+ -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } },
+ ] },
+
+ {
+ -OR => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
+ -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } },
+ },
+
+ ) ),
+ {
+ where => { -or => [
+ -and => [ foo => { '!=', { -value => undef } }, bar => { -in => [ 69, 42 ] } ],
+ foo => { '=', { -value => undef } },
+ baz => { '!=' => { -ident => 'bozz' } },
+ baz => { -ident => 'buzz' },
+ ] },
+ sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz',
+ collapsed_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )',
+ cc_result => { -or => [
+ baz => { '!=' => { -ident => 'bozz' } },
+ baz => { '=' => { -ident => 'buzz' } },
+ foo => undef,
+ { bar => { -in => [ 69, 42 ] }, foo => { '!=', undef } }
+ ] },
+ efcc_result => {},
+ },
+ {
+ where => { -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => { '=' => 1 }, genreid => { '=' => \['?', 2] } ] },
+ sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?',
+ collapsed_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13',
+ cc_result => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] },
+ efcc_result => {},
+ efcc_n_result => {},
+ },
+ {
+ where => { -and => [
+ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
+ -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } },
+ ] },
+ cc_result => { -and => [
+ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
+ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
+ ] },
+ sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)',
+ collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)',
+ efcc_result => {},
+ efcc_n_result => {},
+ },
+ {
+ where => { -and => [
+ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
+ -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } },
+ -and => [ foo => { '=' => \1 }, bar => 2 ],
+ -and => [ foo => 3, bar => { '=' => \4 } ],
+ -exists => \'(SELECT 1)',
+ -exists => \'(SELECT 2)',
+ -not => { foo => 69 },
+ -not => { foo => 42 },
+ ]},
+ sql => 'WHERE
+ ( rank = 13 OR charfield IS NULL OR artistid = ? )
+ AND ( artistid = ? OR charfield IS NULL OR rank != 42 )
+ AND foo = 1
+ AND bar = ?
+ AND foo = ?
+ AND bar = 4
+ AND (EXISTS (SELECT 1))
+ AND (EXISTS (SELECT 2))
+ AND NOT foo = ?
+ AND NOT foo = ?
+ ',
+ collapsed_sql => 'WHERE
+ ( artistid = ? OR charfield IS NULL OR rank = 13 )
+ AND ( artistid = ? OR charfield IS NULL OR rank != 42 )
+ AND (EXISTS (SELECT 1))
+ AND (EXISTS (SELECT 2))
+ AND NOT foo = ?
+ AND NOT foo = ?
+ AND bar = 4
+ AND bar = ?
+ AND foo = 1
+ AND foo = ?
+ ',
+ cc_result => {
+ -and => [
+ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
+ { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] },
+ { -exists => \'(SELECT 1)' },
+ { -exists => \'(SELECT 2)' },
+ { -not => { foo => 69 } },
+ { -not => { foo => 42 } },
+ ],
+ foo => [ -and => { '=' => \1 }, 3 ],
+ bar => [ -and => { '=' => \4 }, 2 ],
+ },
+ efcc_result => {
+ foo => UNRESOLVABLE_CONDITION,
+ bar => UNRESOLVABLE_CONDITION,
+ },
+ efcc_n_result => {
+ foo => UNRESOLVABLE_CONDITION,
+ bar => UNRESOLVABLE_CONDITION,
+ },
+ },
+ {
+ where => { -and => [
+ [ '_macro.to' => { -like => '%correct%' }, '_wc_macros.to' => { -like => '%correct%' } ],
+ { -and => [ { 'group.is_active' => 1 }, { 'me.is_active' => 1 } ] }
+ ] },
+ cc_result => {
+ 'group.is_active' => 1,
+ 'me.is_active' => 1,
+ -or => [
+ '_macro.to' => { -like => '%correct%' },
+ '_wc_macros.to' => { -like => '%correct%' },
+ ],
+ },
+ sql => 'WHERE ( _macro.to LIKE ? OR _wc_macros.to LIKE ? ) AND group.is_active = ? AND me.is_active = ?',
+ efcc_result => { 'group.is_active' => 1, 'me.is_active' => 1 },
+ },
+
+ {
+ where => { -and => [
+ artistid => { -value => [1] },
+ charfield => { -ident => 'foo' },
+ name => { '=' => { -value => undef } },
+ rank => { '=' => { -ident => 'bar' } },
+ ] },
+ sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar',
+ cc_result => {
+ artistid => { -value => [1] },
+ name => undef,
+ charfield => { '=', { -ident => 'foo' } },
+ rank => { '=' => { -ident => 'bar' } },
+ },
+ efcc_result => {
+ artistid => [1],
+ charfield => { -ident => 'foo' },
+ rank => { -ident => 'bar' },
+ },
+ efcc_n_result => {
+ artistid => [1],
+ name => undef,
+ charfield => { -ident => 'foo' },
+ rank => { -ident => 'bar' },
+ },
+ },
+
+ {
+ where => { artistid => [] },
+ cc_result => { artistid => [] },
+ efcc_result => {},
+ },
+ (map {
+ {
+ where => { -and => $_ },
+ cc_result => undef,
+ efcc_result => {},
+ sql => '',
+ },
+ {
+ where => { -or => $_ },
+ cc_result => undef,
+ efcc_result => {},
+ sql => '',
+ },
+ {
+ where => { -or => [ foo => 1, $_ ] },
+ cc_result => { foo => 1 },
+ efcc_result => { foo => 1 },
+ sql => 'WHERE foo = ?',
+ },
+ {
+ where => { -or => [ $_, foo => 1 ] },
+ cc_result => { foo => 1 },
+ efcc_result => { foo => 1 },
+ sql => 'WHERE foo = ?',
+ },
+ {
+ where => { -and => [ fuu => 2, $_, foo => 1 ] },
+ sql => 'WHERE fuu = ? AND foo = ?',
+ collapsed_sql => 'WHERE foo = ? AND fuu = ?',
+ cc_result => { foo => 1, fuu => 2 },
+ efcc_result => { foo => 1, fuu => 2 },
+ },
+ } (
+ # bare
+ [], {},
+ # singles
+ [ {} ], [ [] ],
+ # doubles
+ [ [], [] ], [ {}, {} ], [ [], {} ], [ {}, [] ],
+ # tripples
+ [ {}, [], {} ], [ [], {}, [] ]
+ )),
+
+ # FIXME legacy compat crap, possibly worth undef/dieing in SQLMaker
+ { where => { artistid => {} }, sql => '', cc_result => undef, efcc_result => {}, efcc_n_result => {} },
+
+ # batshit insanity, just to be thorough
+ {
+ where => { -and => [ [ 'artistid' ], [ -and => [ artistid => { '!=', 69 }, artistid => undef, artistid => { '=' => 200 } ]], artistid => [], { -or => [] }, { -and => [] }, [ 'charfield' ], { name => [] }, 'rank' ] },
+ cc_result => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef },
+ sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL',
+ collapsed_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL',
+ efcc_result => { artistid => UNRESOLVABLE_CONDITION },
+ efcc_n_result => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef },
+ },
+
+ # original test from RT#93244
+ {
+ where => {
+ -and => [
+ \[
+ "LOWER(me.title) LIKE ?",
+ '%spoon%',
+ ],
+ [ { 'me.title' => 'Spoonful of bees' } ],
+ ]},
+ cc_result => {
+ -and => [ \[
+ "LOWER(me.title) LIKE ?",
+ '%spoon%',
+ ]],
+ 'me.title' => 'Spoonful of bees',
+ },
+ sql => 'WHERE LOWER(me.title) LIKE ? AND me.title = ?',
+ efcc_result => { 'me.title' => 'Spoonful of bees' },
+ },
+
+ # crazy literals
+ {
+ where => {
+ -or => [
+ \'foo = bar',
+ ],
+ },
+ sql => 'WHERE foo = bar',
+ cc_result => {
+ -and => [
+ \'foo = bar',
+ ],
+ },
+ efcc_result => {},
+ },
+ {
+ where => {
+ -or => [
+ \'foo = bar',
+ \'baz = ber',
+ ],
+ },
+ sql => 'WHERE foo = bar OR baz = ber',
+ collapsed_sql => 'WHERE baz = ber OR foo = bar',
+ cc_result => {
+ -or => [
+ \'baz = ber',
+ \'foo = bar',
+ ],
+ },
+ efcc_result => {},
+ },
+ {
+ where => {
+ -and => [
+ \'foo = bar',
+ \'baz = ber',
+ ],
+ },
+ sql => 'WHERE foo = bar AND baz = ber',
+ cc_result => {
+ -and => [
+ \'foo = bar',
+ \'baz = ber',
+ ],
+ },
+ efcc_result => {},
+ },
+ {
+ where => {
+ -and => [
+ \'foo = bar',
+ \'baz = ber',
+ x => { -ident => 'y' },
+ ],
+ },
+ sql => 'WHERE foo = bar AND baz = ber AND x = y',
+ cc_result => {
+ -and => [
+ \'foo = bar',
+ \'baz = ber',
+ ],
+ x => { '=' => { -ident => 'y' } }
+ },
+ efcc_result => { x => { -ident => 'y' } },
+ },
+);
+
+# these die as of SQLA 1.80 - make sure we do not transform them
+# into something usable instead
+for my $lhs (undef, '', { -ident => 'foo' }, { -value => 'foo' } ) {
+ no warnings 'uninitialized';
+
+ for my $w (
+ ( map { { -or => $_ }, (ref $lhs ? () : { @$_ } ) }
+ [ $lhs => "foo" ],
+ [ $lhs => { "=" => "bozz" } ],
+ [ $lhs => { "=" => \"bozz" } ],
+ [ $lhs => { -max => \"bizz" } ],
+ ),
+
+ (ref $lhs) ? () : (
+ { -or => [ -and => { $lhs => "baz" }, bizz => "buzz" ] },
+ { -or => [ foo => "bar", { $lhs => "baz" }, bizz => "buzz" ] },
+ { foo => "bar", -or => { $lhs => "baz" } },
+ { foo => "bar", -or => { $lhs => \"baz" }, bizz => "buzz" },
+ ),
+
+ { foo => "bar", -and => [ $lhs => \"baz" ], bizz => "buzz" },
+ { foo => "bar", -or => [ $lhs => \"baz" ], bizz => "buzz" },
+
+ { -or => [ foo => "bar", [ $lhs => \"baz" ], bizz => "buzz" ] },
+ { -or => [ foo => "bar", $lhs => \"baz", bizz => "buzz" ] },
+ { -or => [ foo => "bar", $lhs => \["baz"], bizz => "buzz" ] },
+ { -or => [ $lhs => \"baz" ] },
+ { -or => [ $lhs => \["baz"] ] },
+
+ ) {
+ push @tests, {
+ where => $w,
+ throw => qr/
+ \QSupplying an empty left hand side argument is not supported in \E(?:array|hash)-pairs
+ |
+ \QIllegal use of top-level '-\E(?:value|ident)'
+ /x,
+ }
+ }
+}
+
+# these are deprecated as of SQLA 1.79 - make sure we do not transform
+# them without losing the warning
+for my $lhs (undef, '') {
+ for my $rhs ( \"baz", \[ "baz" ] ) {
+ no warnings 'uninitialized';
+
+ my $expected_warning = qr/\QHash-pairs consisting of an empty string with a literal are deprecated/;
+
+ push @tests, {
+ where => { $lhs => $rhs },
+ cc_result => { -and => [ $rhs ] },
+ efcc_result => {},
+ sql => 'WHERE baz',
+ warn => $expected_warning,
+ };
+
+ for my $w (
+ { foo => "bar", -and => { $lhs => $rhs }, bizz => "buzz" },
+ { foo => "bar", $lhs => $rhs, bizz => "buzz" },
+ ) {
+ push @tests, {
+ where => $w,
+ cc_result => {
+ -and => [ $rhs ],
+ bizz => "buzz",
+ foo => "bar",
+ },
+ efcc_result => {
+ foo => "bar",
+ bizz => "buzz",
+ },
+ sql => 'WHERE baz AND bizz = ? AND foo = ?',
+ warn => $expected_warning,
+ };
+ }
+ }
+}
+
+# lots of extra silly tests with a false column
+for my $eq (
+ \"= baz",
+ \[ "= baz" ],
+ { '=' => { -ident => 'baz' } },
+ { '=' => \'baz' },
+) {
+ for my $where (
+ { foo => "bar", -and => [ 0 => $eq ], bizz => "buzz" },
+ { foo => "bar", -or => [ 0 => $eq ], bizz => "buzz" },
+ { foo => "bar", -and => { 0 => $eq }, bizz => "buzz" },
+ { foo => "bar", -or => { 0 => $eq }, bizz => "buzz" },
+ { foo => "bar", 0 => $eq, bizz => "buzz" },
+ ) {
+ push @tests, {
+ where => $where,
+ cc_result => {
+ 0 => $eq,
+ foo => 'bar',
+ bizz => 'buzz',
+ },
+ efcc_result => {
+ foo => 'bar',
+ bizz => 'buzz',
+ ( ref $eq eq 'HASH' ? ( 0 => $eq->{'='} ) : () ),
+ },
+ sql => 'WHERE 0 = baz AND bizz = ? AND foo = ?',
+ };
+
+ push @tests, {
+ where => { -or => $where },
+ cc_result => { -or => [
+ "0" => $eq,
+ bizz => 'buzz',
+ foo => 'bar',
+ ]},
+ efcc_result => {},
+ sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?',
+ }
+
+ }
+
+ for my $where (
+ [ foo => "bar", -and => [ 0 => $eq ], bizz => "buzz" ],
+ [ foo => "bar", -or => [ 0 => $eq ], bizz => "buzz" ],
+ [ foo => "bar", -and => { 0 => $eq }, bizz => "buzz" ],
+ [ foo => "bar", -or => { 0 => $eq }, bizz => "buzz" ],
+ [ foo => "bar", 0 => $eq, bizz => "buzz" ],
+ ) {
+ push @tests, {
+ where => { -or => $where },
+ cc_result => { -or => [
+ "0" => $eq,
+ bizz => 'buzz',
+ foo => 'bar',
+ ]},
+ efcc_result => {},
+ sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?',
+ collapsed_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?',
+ }
+ }
+
+ for my $where (
+ [ {foo => "bar"}, -and => { 0 => "baz" }, bizz => "buzz" ],
+ [ -or => [ foo => "bar", -or => { 0 => "baz" }, bizz => "buzz" ] ],
+ ) {
+ push @tests, {
+ where => { -or => $where },
+ cc_result => { -or => [
+ "0" => 'baz',
+ bizz => 'buzz',
+ foo => 'bar',
+ ]},
+ efcc_result => {},
+ sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?',
+ collapsed_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?',
+ };
+ }
+
+};
+
+for my $t (@tests) {
+ for my $w (
+ $t->{where},
+ $t->{where}, # do it twice, make sure we didn't destory the condition
+ [ -and => $t->{where} ],
+ [ -AND => $t->{where} ],
+ { -OR => [ -AND => $t->{where} ] },
+ ( ( keys %{$t->{where}} == 1 and length( (keys %{$t->{where}})[0] ) )
+ ? [ %{$t->{where}} ]
+ : ()
+ ),
+ ( (keys %{$t->{where}} == 1 and $t->{where}{-or})
+ ? ( ref $t->{where}{-or} eq 'HASH'
+ ? [ map { $_ => $t->{where}{-or}{$_} } sort keys %{$t->{where}{-or}} ]
+ : $t->{where}{-or}
+ )
+ : ()
+ ),
+ ) {
+ die unless Test::Builder->new->is_passing;
+
+ my $name = do { local ($Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (0, 1, 1); Dumper $w };
+
+ my ($collapsed_cond, $collapsed_cond_as_sql);
+
+ if ($t->{throw}) {
+ throws_ok {
+ $collapsed_cond = $schema->storage->_collapse_cond($w);
+ ($collapsed_cond_as_sql) = $sm->where($collapsed_cond);
+ } $t->{throw}, "Exception on attempted collapse/render of $name"
+ and
+ next;
+ }
+
+ warnings_exist {
+ $collapsed_cond = $schema->storage->_collapse_cond($w);
+ ($collapsed_cond_as_sql) = $sm->where($collapsed_cond);
+ } $t->{warn} || [], "Expected warning when collapsing/rendering $name";
+
+ is_deeply(
+ $collapsed_cond,
+ $t->{cc_result},
+ "Expected collapsed condition produced on $name",
+ );
+
+ my ($original_sql) = do {
+ local $SIG{__WARN__} = sub {};
+ $sm->where($w);
+ };
+
+ is_same_sql ( $original_sql, $t->{sql}, "Expected original SQL from $name" )
+ if exists $t->{sql};
+
+ is_same_sql(
+ $collapsed_cond_as_sql,
+ ( $t->{collapsed_sql} || $t->{sql} || $original_sql ),
+ "Collapse did not alter *the semantics* of the final SQL based on $name",
+ );
+
+ is_deeply(
+ $schema->storage->_extract_fixed_condition_columns($collapsed_cond),
+ $t->{efcc_result},
+ "Expected fixed_condition produced on $name",
+ );
+
+ is_deeply(
+ $schema->storage->_extract_fixed_condition_columns($collapsed_cond, 'consider_nulls'),
+ $t->{efcc_n_result},
+ "Expected fixed_condition including NULLs produced on $name",
+ ) if $t->{efcc_n_result};
+
+ is_deeply(
+ $collapsed_cond,
+ $t->{cc_result},
+ "Collapsed condition result unaltered by fixed condition extractor",
+ );
+ }
+}
+
+done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener';
+
use strict;
use warnings;
use Test::More;
-use lib qw(t/lib);
-
-use DBIx::Class::Optional::Dependencies;
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
+use lib qw(t/lib);
use DBICTest::Schema::Artist;
BEGIN {
DBICTest::Schema::Artist->add_column('parentid');
);
}
-use DBICTest;
-use DBICTest::Schema;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest ':DiffSQL';
+use DBIx::Class::_Util 'sigwarn_silencer';
+
+use DBIx::Class::SQLMaker;
+my $sa = DBIx::Class::SQLMaker->new;
+
+$SIG{__WARN__} = sigwarn_silencer( qr/\Q{from} structures with conditions not conforming to the SQL::Abstract syntax are deprecated/ );
+
+my @j = (
+ { child => 'person' },
+ [ { father => 'person' }, { 'father.person_id' => 'child.father_id' }, ],
+ [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+my $match = 'person child JOIN person father ON ( father.person_id = '
+ . 'child.father_id ) JOIN person mother ON ( mother.person_id '
+ . '= child.mother_id )'
+ ;
+is_same_sql(
+ $sa->_recurse_from(@j),
+ $match,
+ 'join 1 ok'
+);
+
+my @j2 = (
+ { mother => 'person' },
+ [ [ { child => 'person' },
+ [ { father => 'person' },
+ { 'father.person_id' => 'child.father_id' }
+ ]
+ ],
+ { 'mother.person_id' => 'child.mother_id' }
+ ],
+);
+$match = 'person mother JOIN (person child JOIN person father ON ('
+ . ' father.person_id = child.father_id )) ON ( mother.person_id = '
+ . 'child.mother_id )'
+ ;
+is_same_sql(
+ $sa->_recurse_from(@j2),
+ $match,
+ 'join 2 ok'
+);
+
+my @j3 = (
+ { child => 'person' },
+ [ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ],
+ [ { mother => 'person', -join_type => 'inner' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+$match = 'person child INNER JOIN person father ON ( father.person_id = '
+ . 'child.father_id ) INNER JOIN person mother ON ( mother.person_id '
+ . '= child.mother_id )'
+ ;
+
+is_same_sql(
+ $sa->_recurse_from(@j3),
+ $match,
+ 'join 3 (inner join) ok'
+);
+
+my @j4 = (
+ { mother => 'person' },
+ [ [ { child => 'person', -join_type => 'left' },
+ [ { father => 'person', -join_type => 'right' },
+ { 'father.person_id' => 'child.father_id' }
+ ]
+ ],
+ { 'mother.person_id' => 'child.mother_id' }
+ ],
+);
+$match = 'person mother LEFT JOIN (person child RIGHT JOIN person father ON ('
+ . ' father.person_id = child.father_id )) ON ( mother.person_id = '
+ . 'child.mother_id )'
+ ;
+is_same_sql(
+ $sa->_recurse_from(@j4),
+ $match,
+ 'join 4 (nested joins + join types) ok'
+);
+
+my @j5 = (
+ { child => 'person' },
+ [ { father => 'person' }, { 'father.person_id' => \'!= child.father_id' }, ],
+ [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+$match = 'person child JOIN person father ON ( father.person_id != '
+ . 'child.father_id ) JOIN person mother ON ( mother.person_id '
+ . '= child.mother_id )'
+ ;
+is_same_sql(
+ $sa->_recurse_from(@j5),
+ $match,
+ 'join 5 (SCALAR reference for ON statement) ok'
+);
+
+done_testing;
use Test::Warn;
use lib qw(t/lib);
-use DBICTest;
-use DBICTest::Schema;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
# This is legacy stuff from SQL::Absract::Limit
# Keep it around just in case someone is using it
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema;
exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003',
exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003',
},
+
+ {
+ order_by => [
+ 'name',
+ ],
+ order_inner => 'name',
+ order_outer => 'name DESC',
+ order_req => 'name',
+ },
) {
my $o_sel = $ord_set->{exselect_outer}
? ', ' . $ord_set->{exselect_outer}
: ''
;
+ my $rs = $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}});
+
+ # query actually works
+ ok( defined $rs->count, 'Query actually works' );
+
is_same_sql_bind(
- $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query,
+ $rs->as_query,
"(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name
FROM (
SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel
[ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
=> 'Library' ] ],
);
+
}
# with groupby
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($LIMIT, $OFFSET) = (
use Test::More;
use lib qw(t/lib);
use List::Util 'min';
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($ROWS, $TOTAL, $OFFSET) = (
DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
use warnings;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype;
my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($TOTAL, $OFFSET) = (
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($TOTAL, $OFFSET, $ROWS) = (
sql => '(
SELECT id, artist__id, bleh
FROM (
- SELECT id, artist__id, bleh, ROWNUM rownum__index
+ SELECT id, artist__id, bleh, ROWNUM AS rownum__index
FROM (
SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR (foo.womble, "blah") AS bleh
FROM cd me
sql => '(
SELECT id, artist__id, bleh
FROM (
- SELECT id, artist__id, bleh, ROWNUM rownum__index
+ SELECT id, artist__id, bleh, ROWNUM AS rownum__index
FROM (
SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR(foo.womble, "blah") AS bleh
FROM cd me
sql => '(
SELECT id, artist__id, bleh
FROM (
- SELECT id, artist__id, bleh, ROWNUM rownum__index
+ SELECT id, artist__id, bleh, ROWNUM AS rownum__index
FROM (
SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR(foo.womble, "blah") AS bleh
FROM cd me
sql => '(
SELECT id, ends_with_me__id
FROM (
- SELECT id, ends_with_me__id, ROWNUM rownum__index
+ SELECT id, ends_with_me__id, ROWNUM AS rownum__index
FROM (
SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id
FROM cd me
sql => '(
SELECT id, ends_with_me__id
FROM (
- SELECT id, ends_with_me__id, ROWNUM rownum__index
+ SELECT id, ends_with_me__id, ROWNUM AS rownum__index
FROM (
SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id
FROM cd me
'(
SELECT owner_name, owner_books
FROM (
- SELECT owner_name, owner_books, ROWNUM rownum__index
+ SELECT owner_name, owner_books, ROWNUM AS rownum__index
FROM (
SELECT owner.name AS owner_name,
( SELECT COUNT( * ) FROM owners owner WHERE (count.id = owner.id)) AS owner_books
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::LimitDialects;
my ($LIMIT, $OFFSET) = (
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema;
use Test::More;
use Test::Exception;
-use Storable 'dclone';
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
+use DBIx::Class::_Util 'deep_clone';
my $schema = DBICTest->init_schema;
my $native_limit_dialect = $schema->storage->sql_maker->{limit_dialect};
+my $where_string = 'me.title = ? AND source != ? AND source = ?';
+
my @where_bind = (
- [ {} => 'Study' ],
[ {} => 'kama sutra' ],
+ [ {} => 'Study' ],
[ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
);
my @select_bind = (
my $tests = {
LimitOffset => {
+ limit_plain => [
+ "( SELECT me.artistid FROM artist me LIMIT ? )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ]
+ ],
+ ],
limit => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
LIMIT ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
LIMIT ?
OFFSET ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
LIMIT ?
- )',
+ )",
[
@select_bind,
@where_bind,
]
],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
LIMIT ?
OFFSET ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 3 ],
[ { sqlt_datatype => 'integer' } => 1 ],
},
LimitXY => {
+ limit_plain => [
+ "( SELECT me.artistid FROM artist me LIMIT ? )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ]
+ ],
+ ],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
LIMIT ?, ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 1 ],
[ { sqlt_datatype => 'integer' } => 3 ],
},
SkipFirst => {
+ limit_plain => [
+ "( SELECT FIRST ? me.artistid FROM artist me )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ]
+ ],
+ ],
ordered_limit_offset => [
- '(
+ "(
SELECT SKIP ? FIRST ? me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 3 ],
[ { sqlt_datatype => 'integer' } => 4 ],
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT SKIP ? FIRST ? me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 1 ],
[ { sqlt_datatype => 'integer' } => 3 ],
},
FirstSkip => {
+ limit_plain => [
+ "( SELECT FIRST ? me.artistid FROM artist me )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ]
+ ],
+ ],
ordered_limit_offset => [
- '(
+ "(
SELECT FIRST ? SKIP ? me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 4 ],
[ { sqlt_datatype => 'integer' } => 3 ],
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT FIRST ? SKIP ? me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 3 ],
[ { sqlt_datatype => 'integer' } => 1 ],
},
RowNumberOver => do {
- my $unordered_sql = '(
+ my $unordered_sql = "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER() AS rno__row__index
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
) me
) me
WHERE rno__row__index >= ? AND rno__row__index <= ?
- )';
+ )";
- my $ordered_sql = '(
+ my $ordered_sql = "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER( ORDER BY ORDER__BY__001, ORDER__BY__002 ) AS rno__row__index
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
) me
) me
WHERE rno__row__index >= ? AND rno__row__index <= ?
- )';
+ )";
{
+ limit_plain => [
+ "(
+ SELECT me.artistid
+ FROM (
+ SELECT me.artistid, ROW_NUMBER() OVER( ) AS rno__row__index
+ FROM (
+ SELECT me.artistid
+ FROM artist me
+ ) me
+ ) me
+ WHERE rno__row__index >= ? AND rno__row__index <= ?
+ )",
+ [
+ [ { sqlt_datatype => 'integer' } => 1 ],
+ [ { sqlt_datatype => 'integer' } => 5 ],
+ ],
+ ],
limit => [$unordered_sql,
[
@select_bind,
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 2 ],
[ { sqlt_datatype => 'integer' } => 4 ],
RowNum => do {
my $limit_sql = sub {
- sprintf '(
+ sprintf "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
%s
) me
WHERE ROWNUM <= ?
- )', $_[0] || '';
+ )", $_[0] || '';
};
{
+ limit_plain => [
+ "(
+ SELECT me.artistid
+ FROM (
+ SELECT me.artistid
+ FROM artist me
+ ) me
+ WHERE ROWNUM <= ?
+ )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ],
+ ],
+ ],
limit => [ $limit_sql->(),
[
@select_bind,
],
],
limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
- SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index
+ SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
) me
) me
WHERE rownum__index BETWEEN ? AND ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
- SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index
+ SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
WHERE ROWNUM <= ?
) me
WHERE rownum__index >= ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
FROM (
- SELECT me.name, me.id, ROWNUM rownum__index
+ SELECT me.name, me.id, ROWNUM AS rownum__index
FROM (
SELECT me.name, me.id
FROM owners me
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 2 ],
[ { sqlt_datatype => 'integer' } => 4 ],
},
FetchFirst => {
+ limit_plain => [
+ "( SELECT me.artistid FROM artist me FETCH FIRST 5 ROWS ONLY )",
+ [],
+ ],
limit => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
FETCH FIRST 4 ROWS ONLY
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY me.id
) me
ORDER BY me.id DESC
FETCH FIRST 4 ROWS ONLY
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit => [
- '(
+ "(
SELECT me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
FETCH FIRST 4 ROWS ONLY
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
FETCH FIRST 4 ROWS ONLY
) me
ORDER BY ORDER__BY__001, ORDER__BY__002
- )',
+ )",
[
@select_bind,
@order_bind,
@where_bind,
@group_bind,
@having_bind,
- @{ dclone \@order_bind }, # without this is_deeply throws a fit
+ @{ deep_clone \@order_bind }, # without this is_deeply throws a fit
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[],
],
},
Top => {
+ limit_plain => [
+ "( SELECT TOP 5 me.artistid FROM artist me )",
+ [],
+ ],
limit => [
- '(
+ "(
SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset => [
- '(
+ "(
SELECT TOP 4 me.id, owner__id, owner__name, bar, baz
FROM (
SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY me.id
) me
ORDER BY me.id DESC
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit => [
- '(
+ "(
SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ?
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT TOP 4 me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
ORDER BY ? / ?, ?
ORDER BY ORDER__BY__001 DESC, ORDER__BY__002 DESC
) me
ORDER BY ORDER__BY__001, ORDER__BY__002
- )',
+ )",
[
@select_bind,
@order_bind,
@where_bind,
@group_bind,
@having_bind,
- @{ dclone \@order_bind }, # without this is_deeply throws a fit
+ @{ deep_clone \@order_bind }, # without this is_deeply throws a fit
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT TOP 3 me.name, me.id
) me
LEFT JOIN books books
ON books.owner = me.id
- )',
+ )",
[],
],
},
GenericSubQ => {
+ limit_plain => [
+ "(
+ SELECT me.artistid
+ FROM (
+ SELECT me.artistid
+ FROM artist me
+ ) me
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM artist rownum__emulation
+ WHERE rownum__emulation.artistid < me.artistid
+ ) < ?
+ ORDER BY me.artistid ASC
+ )",
+ [
+ [ { sqlt_datatype => 'integer' } => 5 ]
+ ],
+ ],
ordered_limit => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, me.price
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
) me
)
) < ?
ORDER BY me.price DESC, me.id ASC
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
ordered_limit_offset => [
- '(
+ "(
SELECT me.id, owner__id, owner__name, bar, baz
FROM (
SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, me.price
FROM books me
JOIN owners owner
ON owner.id = me.owner
- WHERE source != ? AND me.title = ? AND source = ?
+ WHERE $where_string
GROUP BY (me.id / ?), owner.id
HAVING ?
) me
)
) BETWEEN ? AND ?
ORDER BY me.price DESC, me.id ASC
- )',
+ )",
[
@select_bind,
@where_bind,
],
],
limit_offset_prefetch => [
- '(
+ "(
SELECT me.name, books.id, books.source, books.owner, books.title, books.price
FROM (
SELECT me.name, me.id
LEFT JOIN books books
ON books.owner = me.id
ORDER BY me.name ASC, me.id DESC
- )',
+ )",
[
[ { sqlt_datatype => 'integer' } => 1 ],
[ { sqlt_datatype => 'integer' } => 3 ],
delete $schema->storage->_sql_maker->{_cached_syntax};
$schema->storage->_sql_maker->limit_dialect ($limtype);
- my $can_run = ($limtype eq $native_limit_dialect or $limtype eq 'GenericSubQ');
+ # do the simplest thing possible first
+ if ($tests->{$limtype}{limit_plain}) {
+ is_same_sql_bind(
+ $schema->resultset('Artist')->search(
+ [ -and => [ {}, [] ], -or => [ {}, [] ] ],
+ {
+ columns => 'artistid',
+ join => [ {}, [ [ {}, {} ] ], {} ],
+ prefetch => [ [ [ {}, [] ], {} ], {}, [ {} ] ],
+ order_by => ( $limtype eq 'GenericSubQ' ? 'artistid' : [] ),
+ group_by => [],
+ rows => 5,
+ offset => 0,
+ }
+ )->as_query,
+ @{$tests->{$limtype}{limit_plain}},
+ "$limtype: Plain unordered ungrouped select with limit and no offset",
+ )
+ }
# chained search is necessary to exercise the recursive {where} parser
my $rs = $schema->resultset('BooksInLibrary')->search(
#
# not all tests run on all dialects (somewhere impossible, somewhere makes no sense)
#
+ my $can_run = ($limtype eq $native_limit_dialect or $limtype eq 'GenericSubQ');
# only limit, no offset, no order
if ($tests->{$limtype}{limit}) {
use warnings;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
# the entire point of the subclass is that parenthesis have to be
# just right for ACCESS to be happy
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
- { "artist.artistid" => "me.artist" },
+ { "artist.artistid" => { -ident => "me.artist" } },
],
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
{ me => "cd" },
[
{ "-join_type" => "LEFT", track => "track" },
- { "track.cd" => "me.cdid" },
+ { "track.cd" => { -ident => "me.cdid" } },
],
[
{ artist => "artist" },
- { "artist.artistid" => "me.artist" },
+ { "artist.artistid" => { -ident => "me.artist" } },
],
],
[ 'track.title', 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBICTest::Schema;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
+use DBICTest ':DiffSQL';
my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' });
# cheat
require DBIx::Class::Storage::DBI::mysql;
+*DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { 5 };
bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' );
# check that double-subqueries are properly wrapped
{
- my ($sql, @bind);
- my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
- my $orig_debugobj = $schema->storage->debugobj;
- my $orig_debug = $schema->storage->debug;
-
- $schema->storage->debugobj ($debugobj);
- $schema->storage->debug (1);
-
# the expected SQL may seem wastefully nonsensical - this is due to
# CD's tablename being \'cd', which triggers the "this can be anything"
# mode, and forces a subquery. This in turn forces *another* subquery
# because mysql is being mysql
# Also we know it will fail - never deployed. All we care about is the
- # SQL to compare
- eval { $schema->resultset ('CD')->update({ genreid => undef }) };
- is_same_sql_bind (
- $sql,
- \@bind,
+ # SQL to compare, hence the eval
+ $schema->is_executed_sql_bind( sub {
+ eval { $schema->resultset ('CD')->update({ genreid => undef }) }
+ },[[
'UPDATE cd SET `genreid` = ? WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )',
- [ 'NULL' ],
- 'Correct update-SQL with double-wrapped subquery',
- );
+ [ { dbic_colname => "genreid", sqlt_datatype => "integer" } => undef ],
+ ]], 'Correct update-SQL with double-wrapped subquery' );
# same comment as above
- eval { $schema->resultset ('CD')->delete };
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ eval { $schema->resultset ('CD')->delete }
+ }, [[
'DELETE FROM cd WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )',
- [],
- 'Correct delete-SQL with double-wrapped subquery',
- );
+ ]], 'Correct delete-SQL with double-wrapped subquery' );
# and a couple of really contrived examples (we test them live in t/71mysql.t)
my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } });
my ($count_sql, @count_bind) = @${$rs->count_rs->as_query};
- eval {
- $schema->resultset('Artist')->search(
- { artistid => {
- -in => $rs->get_column('artistid')
- ->as_query
- } },
- )->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] });
- };
-
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ eval {
+ $schema->resultset('Artist')->search(
+ { artistid => {
+ -in => $rs->get_column('artistid')
+ ->as_query
+ } },
+ )->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] });
+ }
+ }, [[
q(
UPDATE `artist`
SET `name` = CONCAT(`name`, '_bell_out_of_', (
WHERE `name` LIKE ?
) `_forced_double_subquery` )
),
- [ ("'baby_%'") x 2 ],
- );
+ ( [ { dbic_colname => "name", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => 'baby_%' ]
+ ) x 2
+ ]]);
- eval {
- $schema->resultset('CD')->search_related('artist',
- { 'artist.name' => { -like => 'baby_with_%' } }
- )->delete
- };
-
- is_same_sql_bind (
- $sql,
- \@bind,
+ $schema->is_executed_sql_bind( sub {
+ eval {
+ $schema->resultset('CD')->search_related('artist',
+ { 'artist.name' => { -like => 'baby_with_%' } }
+ )->delete
+ }
+ }, [[
q(
DELETE FROM `artist`
WHERE `artistid` IN (
FROM (
SELECT `artist`.`artistid`
FROM cd `me`
- INNER JOIN `artist` `artist`
+ JOIN `artist` `artist`
ON `artist`.`artistid` = `me`.`artist`
WHERE `artist`.`name` LIKE ?
) `_forced_double_subquery`
)
),
- [ "'baby_with_%'" ],
- );
-
- $schema->storage->debugobj ($orig_debugobj);
- $schema->storage->debug ($orig_debug);
+ [ { dbic_colname => "artist.name", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => 'baby_with_%' ],
+ ]] );
}
# Test support for straight joins
);
}
+# Test support for inner joins on mysql v3
+for (
+ [ 3 => 'INNER JOIN' ],
+ [ 4 => 'JOIN' ],
+) {
+ my ($ver, $join_op) = @$_;
+
+ # we do not care at this point if data is available, just do a reconnect cycle
+ # to clear the server version cache and then get a new maker
+ {
+ $schema->storage->disconnect;
+ $schema->storage->_sql_maker(undef);
+
+ no warnings 'redefine';
+ local *DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { $ver };
+
+ $schema->storage->ensure_connected;
+ $schema->storage->sql_maker;
+ }
+
+ is_same_sql_bind (
+ $schema->resultset('CD')->search ({}, { prefetch => 'artist' })->as_query,
+ "(
+ SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`,
+ `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield`
+ FROM cd `me`
+ $join_op `artist` `artist` ON `artist`.`artistid` = `me`.`artist`
+ )",
+ [],
+ "default join type works for version $ver",
+ );
+}
+
done_testing;
use Test::Warn;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener';
+
use strict;
use warnings;
-use Test::More;
-
-BEGIN {
- require DBIx::Class::Optional::Dependencies;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
-}
+use Test::More;
use Test::Exception;
use Data::Dumper::Concise;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::Oracle;
#
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener';
+
use strict;
use warnings;
use Test::More;
-BEGIN {
- require DBIx::Class::Optional::Dependencies;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
-}
-
use lib qw(t/lib);
-use DBICTest;
+use DBICTest ':DiffSQL';
use DBIx::Class::SQLMaker::OracleJoins;
-use DBIC::SqlMakerTest;
my $sa = DBIx::Class::SQLMaker::OracleJoins->new;
+for my $rhs ( "me.artist", { -ident => "me.artist" } ) {
+
# my ($self, $table, $fields, $where, $order, @rest) = @_;
my ($sql, @bind) = $sa->select(
[
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
- { "artist.artistid" => "me.artist" },
+ { "artist.artistid" => $rhs },
],
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
{ me => "cd" },
[
{ "-join_type" => "", artist => "artist" },
- { "artist.artistid" => "me.artist" },
+ { "artist.artistid" => $rhs },
],
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
[
{ me => "cd" },
[
+ { "-join_type" => "right", artist => "artist" },
+ { "artist.artistid" => $rhs },
+ ],
+ ],
+ [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ { 'artist.artistid' => 3 },
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist(+) ) AND ( artist.artistid = ? ) ) )', [3],
+ 'WhereJoins search with where clause'
+);
+
+($sql, @bind) = $sa->select(
+ [
+ { me => "cd" },
+ [
{ "-join_type" => "LEFT", artist => "artist" },
- { "artist.artistid" => "me.artist" },
+ { "artist.artistid" => $rhs },
],
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
'WhereJoins search with or in where clause'
);
+}
+
done_testing;
use Test::Exception;
use Data::Dumper::Concise;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
sub test_order {
my $rs = shift;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest ':DiffSQL';
+
+my $schema = DBICTest->init_schema( no_deploy => 1 );
+
+$schema->connection(
+ @{ $schema->storage->_dbi_connect_info },
+ { AutoCommit => 1, quote_char => [qw/[ ]/] }
+);
+
+my $rs = $schema->resultset('CD')->search(
+ { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
+ { join => 'artist' }
+)->count_rs;
+
+my $expected_bind = [
+ [ { dbic_colname => "artist.name", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => 'Caterwauler McCrae' ],
+ [ { dbic_colname => "me.year", sqlt_datatype => "varchar", sqlt_size => 100 }
+ => 2001 ],
+];
+
+is_same_sql_bind(
+ $rs->as_query,
+ "(SELECT COUNT( * ) FROM cd [me] JOIN [artist] [artist] ON [artist].[artistid] = [me].[artist] WHERE ( [artist].[name] = ? AND [me].[year] = ? ))",
+ $expected_bind,
+ 'got correct SQL for count query with bracket quoting'
+);
+
+$schema->storage->sql_maker->quote_char('`');
+$schema->storage->sql_maker->name_sep('.');
+
+is_same_sql_bind (
+ $rs->as_query,
+ "(SELECT COUNT( * ) FROM cd `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? ))",
+ $expected_bind,
+ 'got correct SQL for count query with mysql quoting'
+);
+
+# !!! talk to ribasushi *explicitly* before modfying these tests !!!
+{
+ is_same_sql_bind(
+ $schema->resultset('CD')->search({}, { order_by => 'year DESC', columns => 'cdid' })->as_query,
+ '(SELECT `me`.`cdid` FROM cd `me` ORDER BY `year DESC`)',
+ [],
+ 'quoted ORDER BY with DESC (should use a scalarref anyway)'
+ );
+
+ is_same_sql_bind(
+ $schema->resultset('CD')->search({}, { order_by => \'year DESC', columns => 'cdid' })->as_query,
+ '(SELECT `me`.`cdid` FROM cd `me` ORDER BY year DESC)',
+ [],
+ 'did not quote ORDER BY with scalarref',
+ );
+}
+
+is_same_sql(
+ scalar $schema->storage->sql_maker->update('group', { order => 12, name => 'Bill' }),
+ 'UPDATE `group` SET `name` = ?, `order` = ?',
+ 'quoted table names for UPDATE' );
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
-
-my $schema = DBICTest->init_schema();
-
-$schema->storage->sql_maker->quote_char('`');
-$schema->storage->sql_maker->name_sep('.');
-
-my ($sql, @bind);
-$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
-$schema->storage->debug(1);
-
-my $rs;
-
-$rs = $schema->resultset('CD')->search(
- { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
- { join => 'artist' });
-eval { $rs->count };
-is_same_sql_bind(
- $sql, \@bind,
- "SELECT COUNT( * ) FROM cd `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
- 'got correct SQL for count query with quoting'
-);
-
-my $order = 'year DESC';
-$rs = $schema->resultset('CD')->search({},
- { 'order_by' => $order });
-eval { $rs->first };
-like($sql, qr/ORDER BY `\Q${order}\E`/, 'quoted ORDER BY with DESC (should use a scalarref anyway)');
-
-$rs = $schema->resultset('CD')->search({},
- { 'order_by' => \$order });
-eval { $rs->first };
-like($sql, qr/ORDER BY \Q${order}\E/, 'did not quote ORDER BY with scalarref');
-
-$schema->storage->sql_maker->quote_char([qw/[ ]/]);
-$schema->storage->sql_maker->name_sep('.');
-
-$rs = $schema->resultset('CD')->search(
- { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
- { join => 'artist' });
-eval { $rs->count };
-is_same_sql_bind(
- $sql, \@bind,
- "SELECT COUNT( * ) FROM cd [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
- 'got correct SQL for count query with bracket quoting'
-);
-
-my %data = (
- name => 'Bill',
- order => '12'
-);
-
-$schema->storage->sql_maker->quote_char('`');
-$schema->storage->sql_maker->name_sep('.');
-
-is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-use DBIC::DebugObj;
-
-my $schema = DBICTest->init_schema();
-
-my $dsn = $schema->storage->_dbi_connect_info->[0];
-$schema->connection(
- $dsn,
- undef,
- undef,
- { AutoCommit => 1 },
- { quote_char => '`', name_sep => '.' },
-);
-
-my ($sql, @bind);
-$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
-$schema->storage->debug(1);
-
-my $rs;
-
-$rs = $schema->resultset('CD')->search(
- { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
- { join => 'artist' });
-eval { $rs->count };
-is_same_sql_bind(
- $sql, \@bind,
- "SELECT COUNT( * ) FROM cd `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
- 'got correct SQL for count query with quoting'
-);
-
-my $order = 'year DESC';
-$rs = $schema->resultset('CD')->search({},
- { 'order_by' => $order });
-eval { $rs->first };
-like($sql, qr/ORDER BY `\Q${order}\E`/, 'quoted ORDER BY with DESC (should use a scalarref anyway)');
-
-$rs = $schema->resultset('CD')->search({},
- { 'order_by' => \$order });
-eval { $rs->first };
-like($sql, qr/ORDER BY \Q${order}\E/, 'did not quote ORDER BY with scalarref');
-
-$schema->connection(
- $dsn,
- undef,
- undef,
- { AutoCommit => 1, quote_char => [qw/[ ]/], name_sep => '.' }
-);
-
-$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
-$schema->storage->debug(1);
-
-$rs = $schema->resultset('CD')->search(
- { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
- { join => 'artist' });
-eval { $rs->count };
-is_same_sql_bind(
- $sql, \@bind,
- "SELECT COUNT( * ) FROM cd [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
- 'got correct SQL for count query with bracket quoting'
-);
-
-my %data = (
- name => 'Bill',
- order => '12'
-);
-
-$schema->connection(
- $dsn,
- undef,
- undef,
- { AutoCommit => 1, quote_char => '`', name_sep => '.' }
-);
-
-is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-done_testing;
use Test::More;
use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
+use DBICTest ':DiffSQL';
my $schema = DBICTest->init_schema;
my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
-is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
- 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
-
my $storage = $schema->storage;
-$storage->ensure_connected;
+
+is(
+ ref($storage),
+ 'DBIx::Class::Storage::DBI::SQLite',
+ 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite'
+) unless $ENV{DBICTEST_VIA_REPLICATED};
throws_ok {
$schema->storage->throw_exception('test_exception_42');
} qr/prepare_cached failed/, 'exception via DBI->HandleError, etc';
+# make sure repeated disconnection works
+{
+ my $fn = DBICTest->_sqlite_dbfilename;
+
+ lives_ok {
+ $schema->storage->ensure_connected;
+ my $dbh = $schema->storage->dbh;
+ $schema->storage->disconnect for 1,2;
+ unlink $fn;
+ $dbh->disconnect;
+ };
+
+ lives_ok {
+ $schema->storage->ensure_connected;
+ $schema->storage->disconnect for 1,2;
+ unlink $fn;
+ $schema->storage->disconnect for 1,2;
+ };
+
+ lives_ok {
+ $schema->storage->ensure_connected;
+ $schema->storage->_dbh->disconnect;
+ unlink $fn;
+ $schema->storage->disconnect for 1,2;
+ };
+}
+
+
# testing various invocations of connect_info ([ ... ])
my $coderef = sub { 42 };
is($schema->resultset("Artist")->search(), 3, "Three artists returned");
} 'Custom cursor autoloaded';
+# test component_class reentrancy
SKIP: {
- eval { require Class::Unload }
- or skip 'component_class reentrancy test requires Class::Unload', 1;
+ DBIx::Class::Optional::Dependencies->skip_without( 'Class::Unload>=0.07' );
Class::Unload->unload('DBICTest::Cursor');
my $schema = DBICTest->init_schema();
my $storage = $schema->storage;
+$storage = $storage->master
+ if $ENV{DBICTEST_VIA_REPLICATED};
+
+
# test (re)connection
for my $disconnect (0, 1) {
$schema->storage->_dbh->disconnect if $disconnect;
# test nested aliasing
my $res = 'original';
-$storage->dbh_do (sub {
+$schema->storage->dbh_do (sub {
shift->dbh_do(sub { $_[3] = 'changed' }, @_)
}, $res);
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_prettydebug';
+
use strict;
use warnings;
+
use lib qw(t/lib);
use DBICTest;
use Test::More;
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_prettydebug')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_prettydebug');
-}
-
BEGIN { delete @ENV{qw(DBIC_TRACE_PROFILE)} }
{
is($schema->storage->debugobj->_sqlat->indent_string, ' ', 'indent string set correctly from console profile');
}
-{
+SKIP:{
+ DBIx::Class::Optional::Dependencies->skip_without('config_file_reader' );
+
local $ENV{DBIC_TRACE_PROFILE} = './t/lib/awesome.json';
my $schema = DBICTest->init_schema;
use warnings;
no warnings 'once';
+BEGIN {
+ delete @ENV{qw(
+ DBIC_TRACE
+ DBIC_TRACE_PROFILE
+ DBICTEST_SQLITE_USE_FILE
+ DBICTEST_VIA_REPLICATED
+ )};
+}
+
use Test::More;
use Test::Exception;
+use Try::Tiny;
+use File::Spec;
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj;
-use DBIC::SqlMakerTest;
use Path::Class qw/file/;
-BEGIN { delete @ENV{qw(DBIC_TRACE DBIC_TRACE_PROFILE DBICTEST_SQLITE_USE_FILE)} }
-
my $schema = DBICTest->init_schema();
my $lfn = file("t/var/sql-$$.log");
if -e $lfn;
# make sure we are testing the vanilla debugger and not ::PrettyPrint
+require DBIx::Class::Storage::Statistics;
$schema->storage->debugobj(DBIx::Class::Storage::Statistics->new);
ok ( $schema->storage->debug(1), 'debug' );
}
open(STDERRCOPY, '>&STDERR');
-close(STDERR);
-dies_ok {
+
+my $exception_line_number;
+# STDERR will be closed, no T::B diag in blocks
+my $exception = try {
+ close(STDERR);
+ $exception_line_number = __LINE__ + 1; # important for test, do not reformat
$schema->resultset('CD')->search({})->count;
-} 'Died on closed FH';
+} catch {
+ $_
+} finally {
+ # restore STDERR
+ open(STDERR, '>&STDERRCOPY');
+};
+
+ok $exception =~ /
+ \QDuplication of STDERR for debug output failed (perhaps your STDERR is closed?)\E
+ .+
+ \Qat @{[__FILE__]} line $exception_line_number\E$
+/xms
+ or diag "Unexpected exception text:\n\n$exception\n";
+
+my @warnings;
+$exception = try {
+ local $SIG{__WARN__} = sub { push @warnings, @_ if $_[0] =~ /character/i };
+ close STDERR;
+ open(STDERR, '>', File::Spec->devnull) or die $!;
+ $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count;
+ '';
+} catch {
+ $_;
+} finally {
+ # restore STDERR
+ close STDERR;
+ open(STDERR, '>&STDERRCOPY');
+};
+
+die "How did that fail... $exception"
+ if $exception;
+
+is_deeply(\@warnings, [], 'No warnings with unicode on STDERR');
+
+# test debugcb and debugobj protocol
+{
+ my $rs = $schema->resultset('CD')->search( {
+ artist => 1,
+ cdid => { -between => [ 1, 3 ] },
+ title => { '!=' => \[ '?', undef ] }
+ });
+
+ my $sql_trace = 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( artist = ? AND ( cdid BETWEEN ? AND ? ) AND title != ? ) )';
+ my @bind_trace = qw( '1' '1' '3' NULL ); # quotes are in fact part of the trace </facepalm>
+
+
+ my @args;
+ $schema->storage->debugcb(sub { push @args, @_ } );
-open(STDERR, '>&STDERRCOPY');
+ $rs->all;
+
+ is_deeply( \@args, [
+ "SELECT",
+ sprintf( "%s: %s\n", $sql_trace, join ', ', @bind_trace ),
+ ]);
+
+ {
+ package DBICTest::DebugObj;
+ our @ISA = 'DBIx::Class::Storage::Statistics';
+
+ sub query_start {
+ my $self = shift;
+ ( $self->{_traced_sql}, @{$self->{_traced_bind}} ) = @_;
+ }
+ }
+
+ my $do = $schema->storage->debugobj(DBICTest::DebugObj->new);
+
+ $rs->all;
+
+ is( $do->{_traced_sql}, $sql_trace );
+
+ is_deeply ( $do->{_traced_bind}, \@bind_trace );
+}
-# test trace output correctness for bind params
+# recreate test as seen in DBIx::Class::QueryLog
+# the rationale is that if someone uses a non-IO::Handle object
+# on CPAN, many are *bound* to use one on darkpan. Thus this
+# test to ensure there is no future silent breakage
{
- my ($sql, @bind);
- $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
-
- my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
- is_same_sql_bind(
- $sql, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) )",
- [qw/'1' '1' '3'/],
- 'got correct SQL with all bind parameters (debugcb)'
- );
-
- @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
- is_same_sql_bind(
- $sql, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) )", ["'1'", "'1'", "'3'"],
- 'got correct SQL with all bind parameters (debugobj)'
- );
+ my $output = "";
+
+ {
+ package DBICTest::_Printable;
+
+ sub print {
+ my ($self, @args) = @_;
+ $output .= join('', @args);
+ }
+ }
+
+ $schema->storage->debugobj(undef);
+ $schema->storage->debug(1);
+ $schema->storage->debugfh( bless {}, "DBICTest::_Printable" );
+ $schema->storage->txn_do( sub { $schema->resultset('Artist')->count } );
+
+ like (
+ $output,
+ qr/
+ \A
+ ^ \QBEGIN WORK\E \s*?
+ ^ \QSELECT COUNT( * ) FROM artist me:\E \s*?
+ ^ \QCOMMIT\E \s*?
+ \z
+ /xm
+ );
+
+ $schema->storage->debug(0);
+ $schema->storage->debugfh(undef);
}
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy';
+
use strict;
use warnings;
use lib qw(t/lib);
use DBICTest;
-BEGIN {
- require DBIx::Class;
- plan skip_all =>
- 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
-}
-
local $ENV{DBI_DSN};
# this is how maint/gen_schema did it (connect() to force a storage
# there ought to be more code like this in the wild
like(
DBICTest::Schema->connect->deployment_statements('SQLite'),
- qr/\bCREATE TABLE\b/i
+ qr/\bCREATE TABLE artist\b/i # ensure quoting *is* disabled
);
lives_ok( sub {
$parse_schema->resultset("Artist")->all();
}, 'artist table deployed correctly' );
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( quote_names => 1 );
my $var = dir ("t/var/ddl_dir-$$");
$var->mkpath unless -d $var;
my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' );
$test_dir_1->rmtree if -d $test_dir_1;
-$schema->create_ddl_dir( undef, undef, $test_dir_1 );
+$schema->create_ddl_dir( [qw(SQLite MySQL)], 1, $test_dir_1 );
ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' );
ok( scalar( glob $test_dir_1.'/*.sql' ), 'there are sql files in there' );
+my $less = $schema->clone;
+$less->unregister_source('BindType');
+$less->create_ddl_dir( [qw(SQLite MySQL)], 2, $test_dir_1, 1 );
+
+for (
+ [ SQLite => '"' ],
+ [ MySQL => '`' ],
+) {
+ my $type = $_->[0];
+ my $q = quotemeta($_->[1]);
+
+ for my $f (map { $test_dir_1->file("DBICTest-Schema-${_}-$type.sql") } qw(1 2) ) {
+ like scalar $f->slurp, qr/CREATE TABLE ${q}track${q}/, "Proper quoting in $f";
+ }
+
+ {
+ local $TODO = 'SQLT::Producer::MySQL has no knowledge of the mythical beast of quoting...'
+ if $type eq 'MySQL';
+
+ my $f = $test_dir_1->file("DBICTest-Schema-1-2-$type.sql");
+ like scalar $f->slurp, qr/DROP TABLE ${q}bindtype_test${q}/, "Proper quoting in diff $f";
+ }
+}
+
{
local $TODO = 'we should probably add some tests here for actual deployability of the DDL?';
ok( 0 );
use strict;
use warnings;
+BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 }
+
use Test::More;
use lib qw(t/lib);
use DBICTest;
use lib qw(t/lib);
use DBICTest;
+for my $conn_args (
+ [ on_connect_do => "_NOPE_" ],
+ [ on_connect_call => sub { shift->_dbh->do("_NOPE_") } ],
+ [ on_connect_call => "_NOPE_" ],
+) {
+ for my $method (qw( ensure_connected _server_info _get_server_version _get_dbh )) {
+
+ my $s = DBICTest->init_schema(
+ no_deploy => 1,
+ on_disconnect_call => sub { fail 'Disconnector should not be invoked' },
+ @$conn_args
+ );
+
+ my $storage = $s->storage;
+ $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED};
+
+ ok( ! $storage->connected, 'Starting unconnected' );
+
+ my $desc = "calling $method with broken on_connect action @{[ explain $conn_args ]}";
+
+ throws_ok { $storage->$method }
+ qr/ _NOPE_ \b/x,
+ "Throwing correctly when $desc";
+
+ ok( ! $storage->connected, "Still not connected after $desc" );
+
+ # this checks that the on_disconect_call FAIL won't trigger
+ $storage->disconnect;
+ }
+}
+
+for my $conn_args (
+ [ on_disconnect_do => "_NOPE_" ],
+ [ on_disconnect_call => sub { shift->_dbh->do("_NOPE_") } ],
+ [ on_disconnect_call => "_NOPE_" ],
+) {
+ my $s = DBICTest->init_schema( no_deploy => 1, @$conn_args );
+
+ my $storage = $s->storage;
+ $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED};
+
+ my $desc = "broken on_disconnect action @{[ explain $conn_args ]}";
+
+ # connect + ping
+ my $dbh = $storage->dbh;
+
+ ok ($dbh->FETCH('Active'), 'Freshly connected DBI handle is healthy');
+
+ warnings_exist { eval { $storage->disconnect } } [
+ qr/\QDisconnect action failed\E .+ _NOPE_ \b/x
+ ], "Found warning of failed $desc";
+
+ ok (! $dbh->FETCH('Active'), "Actual DBI disconnect was not prevented by $desc" );
+}
+
my $schema = DBICTest->init_schema;
warnings_are ( sub {
# exception fallback:
SKIP: {
- if (DBIx::Class::_ENV_::PEEPEENESS) {
+ if ( !!DBIx::Class::_ENV_::PEEPEENESS ) {
skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1;
}
use Test::More;
+# so we can see the retry exceptions (if any)
+BEGIN { $ENV{DBIC_STORAGE_RETRY_DEBUG} = 1 }
+
use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
# to induce out-of-order destruction
$DBICTest::FakeSchemaFactory::schema = $schema;
- # so we can see the retry exceptions (if any)
- $ENV{DBIC_DBIRETRY_DEBUG} = 1;
-
ok (!$schema->storage->connected, "$type: start disconnected");
$schema->txn_do (sub {
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DBIC::DebugObj;
-use DBIC::SqlMakerTest;
-use DBI::Const::GetInfoType;
{ # Fake storage driver for SQLite + no bind variables
package DBICTest::SQLite::NoBindVars;
- use Class::C3;
- use base qw/
- DBIx::Class::Storage::DBI::NoBindVars
- DBIx::Class::Storage::DBI::SQLite
- /;
+ use base qw(
+ DBIx::Class::Storage::DBI::NoBindVars
+ DBIx::Class::Storage::DBI::SQLite
+ );
+ use mro 'c3';
}
my $schema = DBICTest->init_schema (storage_type => 'DBICTest::SQLite::NoBindVars', no_populate => 1);
is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists
-my ($sql, @bind);
-my $orig_debugobj = $schema->storage->debugobj;
-my $orig_debug = $schema->storage->debug;
-$schema->storage->debugobj (DBIC::DebugObj->new (\$sql, \@bind) );
-$schema->storage->debug (1);
-
-is( $it->next->name, "Artist 2", "iterator->next ok" );
-$it->next;
-$it->next;
-is( $it->next, undef, "next past end of resultset ok" );
-
-$schema->storage->debugobj ($orig_debugobj);
-$schema->storage->debug ($orig_debug);
-
-is_same_sql_bind (
- $sql,
- \@bind,
- 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me ORDER BY artistid LIMIT 3 OFFSET 2',
- [],
- 'Correctly interpolated SQL'
-);
+$schema->is_executed_sql_bind( sub {
+ is( $it->next->name, "Artist 2", "iterator->next ok" );
+ $it->next;
+ $it->next;
+ is( $it->next, undef, "next past end of resultset ok" );
+}, [
+ [ 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me ORDER BY artistid LIMIT 3 OFFSET 2' ],
+], 'Correctly interpolated SQL' );
done_testing;
use strict;
use warnings;
+BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 }
+
# !!! do not replace this with done_testing - tests reside in the callbacks
# !!! number of calls is important
use Test::More tests => 13;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DBIC::SqlMakerTest;
my $ping_count = 0;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+{
+ package # hideee
+ DBICTest::CrazyInt;
+
+ use overload
+ '0+' => sub { 666 },
+ '""' => sub { 999 },
+ fallback => 1,
+ ;
+}
+
+# check DBI behavior when fed a stringifiable/nummifiable value
+{
+ my $crazynum = bless {}, 'DBICTest::CrazyInt';
+ cmp_ok( $crazynum, '==', 666 );
+ cmp_ok( $crazynum, 'eq', 999 );
+
+ my $schema = DBICTest->init_schema( no_populate => 1 );
+ $schema->storage->dbh_do(sub {
+ $_[1]->do('INSERT INTO artist (name) VALUES (?)', {}, $crazynum );
+ });
+
+ is( $schema->resultset('Artist')->next->name, 999, 'DBI preferred stringified version' );
+}
+done_testing;
);
# lie that we already locked stuff - the tests below do not touch anything
-$ENV{DBICTEST_LOCK_HOLDER} = -1;
+# unless we are under travis, where the OOM killers reign and things are rough
+$ENV{DBICTEST_LOCK_HOLDER} = -1
+ unless DBICTest::RunMode->is_ci;
# Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
# clashes with libssl, and will segfault everything coming after them
my $schema;
- try {
+ my $sql_maker = try {
$schema = DBICTest::Schema->connect($dsn, $user, $pass, {
quote_names => 1
});
$schema->storage->ensure_connected;
- 1;
+ $schema->storage->sql_maker;
} || next;
my ($exp_quote_char, $exp_name_sep) =
my ($quote_char_text, $name_sep_text) = map { dumper($_) }
($exp_quote_char, $exp_name_sep);
- is_deeply $schema->storage->sql_maker->quote_char,
+ is_deeply $sql_maker->quote_char,
$exp_quote_char,
"$db quote_char with quote_names => 1 is $quote_char_text";
- is $schema->storage->sql_maker->name_sep,
+ is $sql_maker->name_sep,
$exp_name_sep,
"$db name_sep with quote_names => 1 is $name_sep_text";
# if something was produced - it better be quoted
- if ( my $ddl = try { $schema->deployment_statements } ) {
-
- my $quoted_artist = $schema->storage->sql_maker->_quote('artist');
+ if (
+ # the SQLT producer has no idea what quotes are :/
+ ! grep { $db eq $_ } qw( SYBASE DB2 )
+ and
+ my $ddl = try { $schema->deployment_statements }
+ ) {
+ my $quoted_artist = $sql_maker->_quote('artist');
like ($ddl, qr/^CREATE\s+TABLE\s+\Q$quoted_artist/msi, "$db DDL contains expected quoted table name");
}
use warnings;
use FindBin;
+use B::Deparse;
use File::Copy 'move';
+use Scalar::Util 'weaken';
use Test::More;
use Test::Exception;
use lib qw(t/lib);
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
+my $exception_action_count;
+$schema->exception_action(sub {
+ $exception_action_count++;
+ die @_;
+});
+
# Make sure we're connected by doing something
my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }});
cmp_ok(@art, '==', 3, "Three artists returned");
# Catch the DBI connection error
local $SIG{__WARN__} = sub {};
throws_ok {
- my @art_three = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } );
+ $schema->resultset("Artist")->create({ name => 'not gonna happen' });
} qr/not a database/, 'The operation failed';
}
# start disconnected and then connected
$schema->storage->disconnect;
+ $exception_action_count = 0;
+
for (1, 2) {
my $disarmed;
isa_ok ($schema->resultset('Artist')->next, 'DBICTest::Artist');
}, @$args) });
}
+
+ is( $exception_action_count, 0, 'exception_action never called' );
};
+# make sure RT#110429 does not recur on manual DBI-side disconnect
+for my $cref (
+ sub {
+ my $schema = shift;
+
+ my $g = $schema->txn_scope_guard;
+
+ is( $schema->storage->transaction_depth, 1, "Expected txn depth" );
+
+ $schema->storage->_dbh->disconnect;
+
+ $schema->storage->dbh_do(sub { $_[1]->do('SELECT 1') } );
+ },
+ sub {
+ my $schema = shift;
+ $schema->txn_do(sub {
+ $schema->storage->_dbh->disconnect
+ } );
+ },
+ sub {
+ my $schema = shift;
+ $schema->txn_do(sub {
+ $schema->storage->disconnect;
+ die "VIOLENCE";
+ } );
+ },
+) {
+
+ note( "Testing with " . B::Deparse->new->coderef2text($cref) );
+
+ $schema->storage->disconnect;
+ $exception_action_count = 0;
+
+ ok( !$schema->storage->connected, 'Not connected' );
+
+ is( $schema->storage->transaction_depth, undef, "Start with unknown txn depth" );
+
+ # messages vary depending on version and whether txn or do, whatever
+ dies_ok {
+ $cref->($schema)
+ } 'Threw *something*';
+
+ ok( !$schema->storage->connected, 'Not connected as a result of failed rollback' );
+
+ is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" );
+
+ is( $exception_action_count, 1, "exception_action called only once" );
+}
+
+# check exception_action under tenacious disconnect
+{
+ $schema->storage->disconnect;
+ $exception_action_count = 0;
+
+ throws_ok { $schema->txn_do(sub {
+ $schema->storage->_dbh->disconnect;
+
+ $schema->resultset('Artist')->next;
+ })} qr/prepare on inactive database handle/;
+
+ is( $exception_action_count, 1, "exception_action called only once" );
+}
+
+# check that things aren't crazy with a non-violent disconnect
+{
+ my $schema = DBICTest->init_schema( sqlite_use_file => 0, no_deploy => 1 );
+ weaken( my $ws = $schema );
+
+ $schema->is_executed_sql_bind( sub {
+ $ws->txn_do(sub { $ws->storage->disconnect } );
+ }, [ [ 'BEGIN' ] ], 'Only one BEGIN statement' );
+
+ $schema->is_executed_sql_bind( sub {
+ my $g = $ws->txn_scope_guard;
+ $ws->storage->disconnect;
+ }, [ [ 'BEGIN' ] ], 'Only one BEGIN statement' );
+}
+
done_testing;
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_replicated';
+
use strict;
use warnings;
use Test::More;
-
+use DBIx::Class::_Util 'modver_gt_or_eq_and_lt';
use lib qw(t/lib);
use DBICTest;
BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated');
-
- if (DBICTest::RunMode->is_smoker) {
- my $mver = Moose->VERSION;
- plan skip_all => "A trial version $mver of Moose detected known to break replication - skipping test known to fail"
- if ($mver >= 1.99 and $mver <= 1.9902);
- }
-
+ plan skip_all => "A trial version of Moose detected known to break replication - skipping test known to fail" if (
+ DBICTest::RunMode->is_smoker
+ and
+ modver_gt_or_eq_and_lt( 'Moose', '1.99', '1.9903' )
+ )
}
use Test::Moose;
use List::Util 'first';
use Scalar::Util 'reftype';
use File::Spec;
-use IO::Handle;
use Moose();
use MooseX::Types();
note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer scope_guard);
+
+use lib qw(t/lib);
+use DBICTest;
+
+{
+ package # moar hide
+ DBICTest::SVPTracerObj;
+
+ use base 'DBIx::Class::Storage::Statistics';
+
+ sub query_start { 'do notning'}
+ sub callback { 'dummy '}
+
+ for my $svpcall (map { "svp_$_" } qw(begin rollback release)) {
+ no strict 'refs';
+ *$svpcall = sub { $_[0]{uc $svpcall}++ };
+ }
+}
+
+my $env2optdep = {
+ DBICTEST_PG => 'test_rdbms_pg',
+ DBICTEST_MYSQL => 'test_rdbms_mysql',
+};
+
+my $schema;
+
+for ('', keys %$env2optdep) { SKIP: {
+
+ my $prefix;
+
+ if ($prefix = $_) {
+ my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
+
+ skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1)
+ unless $dsn;
+
+ skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
+ unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
+
+ $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
+
+ my $create_sql;
+ $schema->storage->ensure_connected;
+ if ($schema->storage->isa('DBIx::Class::Storage::DBI::Pg')) {
+ $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
+ $schema->storage->dbh->do('SET client_min_messages=WARNING');
+ }
+ elsif ($schema->storage->isa('DBIx::Class::Storage::DBI::mysql')) {
+ $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
+ }
+ else {
+ skip( 'Untested driver ' . $schema->storage, 1 );
+ }
+
+ $schema->storage->dbh_do (sub {
+ $_[1]->do('DROP TABLE IF EXISTS artist');
+ $_[1]->do($create_sql);
+ });
+ }
+ else {
+ $prefix = 'SQLite Internal DB';
+ $schema = DBICTest->init_schema( no_populate => 1, auto_savepoint => 1 );
+ }
+
+ note "Testing $prefix";
+
+ # can not use local() due to an unknown number of storages
+ # (think replicated)
+ my $orig_states = { map
+ { $_ => $schema->storage->$_ }
+ qw(debugcb debugobj debug)
+ };
+ my $sg = scope_guard {
+ $schema->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states;
+ };
+ $schema->storage->debugobj (my $stats = DBICTest::SVPTracerObj->new);
+ $schema->storage->debug (1);
+
+ $schema->resultset('Artist')->create({ name => 'foo' });
+
+ $schema->txn_begin;
+
+ my $arty = $schema->resultset('Artist')->find(1);
+
+ my $name = $arty->name;
+
+ # First off, test a generated savepoint name
+ $schema->svp_begin;
+
+ cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
+
+ $arty->update({ name => 'Jheephizzy' });
+
+ $arty->discard_changes;
+
+ cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
+
+ # Rollback the generated name
+ # Active: 0
+ $schema->svp_rollback;
+
+ cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+
+ $arty->discard_changes;
+
+ cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
+
+ $arty->update({ name => 'Jheephizzy'});
+
+ # Active: 0 1
+ $schema->svp_begin('testing1');
+
+ $arty->update({ name => 'yourmom' });
+
+ # Active: 0 1 2
+ $schema->svp_begin('testing2');
+
+ $arty->update({ name => 'gphat' });
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'gphat', 'name changed');
+
+ # Active: 0 1 2
+ # Rollback doesn't DESTROY the savepoint, it just rolls back to the value
+ # at its conception
+ $schema->svp_rollback('testing2');
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted');
+
+ # Active: 0 1 2 3
+ $schema->svp_begin('testing3');
+ $arty->update({ name => 'coryg' });
+
+ # Active: 0 1 2 3 4
+ $schema->svp_begin('testing4');
+ $arty->update({ name => 'watson' });
+
+ # Release 3, which implicitly releases 4
+ # Active: 0 1 2
+ $schema->svp_release('testing3');
+
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'watson', 'release left data');
+
+ # This rolls back savepoint 2
+ # Active: 0 1 2
+ $schema->svp_rollback;
+
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2');
+
+ # Rollback the original savepoint, taking us back to the beginning, implicitly
+ # rolling back savepoint 1 and 2
+ $schema->svp_rollback('savepoint_0');
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start');
+
+ $schema->txn_commit;
+
+ is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' );
+
+ # And now to see if txn_do will behave correctly
+ $schema->txn_do (sub {
+ my $artycp = $arty;
+
+ $schema->txn_do (sub {
+ $artycp->name ('Muff');
+ $artycp->update;
+ });
+
+ eval {
+ $schema->txn_do (sub {
+ $artycp->name ('Moff');
+ $artycp->update;
+ $artycp->discard_changes;
+ is($artycp->name,'Moff','Value updated in nested transaction');
+ $schema->storage->dbh->do ("GUARANTEED TO PHAIL");
+ });
+ };
+
+ ok ($@,'Nested transaction failed (good)');
+
+ $arty->discard_changes;
+
+ is($arty->name,'Muff','auto_savepoint rollback worked');
+
+ $arty->name ('Miff');
+
+ $arty->update;
+ });
+
+ is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' );
+
+ $arty->discard_changes;
+
+ is($arty->name,'Miff','auto_savepoint worked');
+
+ cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created');
+
+ cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released');
+
+ cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
+
+### test originally written for SQLite exclusively (git blame -w -C -M)
+ # test two-phase commit and inner transaction rollback from nested transactions
+ my $ars = $schema->resultset('Artist');
+
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_outer_transaction' });
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction' });
+ });
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction visible in outer transaction');
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction_rolling_back' });
+ die 'rolling back inner transaction';
+ });
+ } qr/rolling back inner transaction/, 'inner transaction rollback executed';
+ $ars->create({ name => 'in_outer_transaction2' });
+ });
+
+ is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' );
+
+SKIP: {
+ skip "Reading inexplicably fails on very old replicated DBD::SQLite<1.33", 1 if (
+ $ENV{DBICTEST_VIA_REPLICATED}
+ and
+ $prefix eq 'SQLite Internal DB'
+ and
+ ! modver_gt_or_eq('DBD::SQLite', '1.33')
+ );
+
+ ok($ars->search({ name => 'in_outer_transaction' })->first,
+ 'commit from outer transaction');
+ ok($ars->search({ name => 'in_outer_transaction2' })->first,
+ 'second commit from outer transaction');
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction');
+ is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
+ undef,
+ 'rollback from inner transaction';
+}
+
+### cleanupz
+ $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") });
+}}
+
+done_testing;
+
+END {
+ local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state of handle/ )
+ unless modver_gt_or_eq('DBD::SQLite', '1.33');
+ eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }) } if defined $schema;
+ undef $schema;
+}
for my $want (0,1) {
my $schema = DBICTest->init_schema;
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+ is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
my @titles = map {'txn_do test CD ' . $_} (1..5);
my $artist = $schema->resultset('Artist')->find(1);
title => "txn_do test CD $_",
})->first->year, 2006, "new CD $_ year correct") for (1..5);
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
+ is( $schema->storage->transaction_depth, 0, 'txn depth has been reset');
}
# Test txn_do() @_ aliasing support
{
my $schema = DBICTest->init_schema;
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+ is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
my $nested_code = sub {
my ($schema, $artist, $code) = @_;
})->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs');
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
+ is( $schema->storage->transaction_depth, 0, 'txn depth has been reset');
}
# test nested txn_begin on fresh connection
is ($schema->storage->transaction_depth, 0, 'Start outside txn');
my @pids;
+ SKIP:
for my $action (
sub {
my $s = shift;
},
) {
my $pid = fork();
- die "Unable to fork: $!\n"
- if ! defined $pid;
+
+ if( ! defined $pid ) {
+ skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1
+ if $! == Errno::EAGAIN();
+
+ die "Unable to fork: $!"
+ }
if ($pid) {
push @pids, $pid;
if $^O eq 'MSWin32';
my $pid = fork();
- die "Unable to fork: $!\n"
- if ! defined $pid;
+ if( ! defined $pid ) {
+
+ skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1
+ if $! == Errno::EAGAIN();
+
+ die "Unable to fork: $!"
+ }
if ($pid) {
push @pids, $pid;
# Test failed txn_do()
for my $pass (1,2) {
- is( $schema->storage->{transaction_depth}, 0, "txn depth starts at 0 (pass $pass)");
+ is( $schema->storage->transaction_depth, 0, "txn depth starts at 0 (pass $pass)");
my $artist = $schema->resultset('Artist')->find(3);
})->first;
ok(!defined($cd), qq{failed txn_do didn't change the cds table (pass $pass)});
- is( $schema->storage->{transaction_depth}, 0, "txn depth has been reset (pass $pass)");
+ is( $schema->storage->transaction_depth, 0, "txn depth has been reset (pass $pass)");
}
# Test failed txn_do() with failed rollback
{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+ is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
my $artist = $schema->resultset('Artist')->find(3);
{
my $schema = DBICTest->init_schema();
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+ is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
my $nested_fail_code = sub {
my ($schema, $artist, $code1, $code2) = @_;
} [], 'No warnings on AutoCommit => 0 with txn_do';
+
+# make sure we are not fucking up the stacktrace on broken overloads
+{
+ package DBICTest::BrokenOverload;
+
+ use overload '""' => sub { $_[0] };
+}
+
+{
+ my @w;
+ local $SIG{__WARN__} = sub {
+ $_[0] =~ /\QExternal exception class DBICTest::BrokenOverload implements partial (broken) overloading preventing its instances from being used in simple (\E\$x eq \$y\Q) comparisons/
+ ? push @w, @_
+ : warn @_
+ };
+
+ my $s = DBICTest->init_schema(no_deploy => 1);
+ $s->stacktrace(0);
+ my $g = $s->storage->txn_scope_guard;
+ my $broken_exception = bless {}, 'DBICTest::BrokenOverload';
+
+ # FIXME - investigate what confuses the regex engine below
+
+ # do not reformat - line-num part of the test
+ my $ln = __LINE__ + 6;
+ throws_ok {
+ $s->txn_do( sub {
+ $s->txn_do( sub {
+ $s->storage->_dbh->disconnect;
+ die $broken_exception
+ });
+ })
+ } qr/\QTransaction aborted: $broken_exception. Rollback failed: DBIx::Class::Storage::DBI::txn_rollback(): lost connection to storage at @{[__FILE__]} line $ln\E\n/; # FIXME wtf - ...\E$/m doesn't work here
+
+ is @w, 1, 'One matching warning only';
+
+ # try the same broken exception object, but have exception_action inject it
+ $s->exception_action(sub { die $broken_exception });
+ eval {
+ $s->txn_do( sub {
+ die "some string masked away";
+ });
+ };
+ isa_ok $@, 'DBICTest::BrokenOverload', 'Deficient exception properly propagated';
+
+ is @w, 2, 'The warning was emitted a second time';
+}
+
done_testing;
use Test::More;
use Test::Warn;
use Test::Exception;
+
+use List::Util 'shuffle';
+use DBIx::Class::_Util 'sigwarn_silencer';
+
use lib qw(t/lib);
use DBICTest;
{
my $schema = DBICTest->init_schema;
- no strict 'refs';
no warnings 'redefine';
-
- local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+ local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' };
Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
throws_ok (sub {
#$schema->storage->_dbh( $schema->storage->_dbh->clone );
die 'Deliberate exception';
- }, ($] >= 5.013008 )
+ }, ( "$]" >= 5.013008 )
? qr/Deliberate exception/s # temporary until we get the generic exception wrapper rolling
: qr/Deliberate exception.+Rollback failed/s
);
# make sure it warns *big* on failed rollbacks
# test with and without a poisoned $@
-for my $pre_poison (0,1) {
-for my $post_poison (0,1) {
-
- my $schema = DBICTest->init_schema(no_populate => 1);
-
- no strict 'refs';
- no warnings 'redefine';
- local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
- Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
-
-#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
-=begin
- warnings_exist (
- sub {
- my $guard = $schema->txn_scope_guard;
- $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-
- # this should freak out the guard rollback
- # but it won't work because DBD::SQLite is buggy
- # instead just install a toxic rollback above
- #$schema->storage->_dbh( $schema->storage->_dbh->clone );
- },
- [
- qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
- qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
- ],
- 'proper warnings generated on out-of-scope+rollback failure'
- );
-=cut
-
-# delete this once the above works properly (same test)
+require DBICTest::AntiPattern::TrueZeroLen;
+require DBICTest::AntiPattern::NullObject;
+{
my @want = (
qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
}
};
- {
- eval { die 'pre-GIFT!' if $pre_poison };
- my $guard = $schema->txn_scope_guard;
- eval { die 'post-GIFT!' if $post_poison };
- $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
- }
+ no warnings 'redefine';
+ local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
- local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...'
- if ( $post_poison and (
- # take no chances on installation
- ( DBICTest::RunMode->is_plain and ($ENV{TRAVIS}||'') ne 'true' )
- or
- # this always fails
- ! $pre_poison
- or
- # I do not understand why but on <= 5.8.8 and on 5.10.0 "$pre_poison && $post_poison" passes...
- ($] > 5.008008 and $] < 5.010000 ) or $] > 5.010000
- ));
+ my @poisons = shuffle (
+ undef,
+ DBICTest::AntiPattern::TrueZeroLen->new,
+ DBICTest::AntiPattern::NullObject->new,
+ 'GIFT!',
+ );
- is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" );
+ for my $pre_poison (@poisons) {
+ for my $post_poison (@poisons) {
- # just to mask off warning since we could not disconnect above
- $schema->storage->_dbh->disconnect;
-}}
+ @w = ();
+
+ my $schema = DBICTest->init_schema(no_populate => 1);
+
+ # the actual scope where the guard is created/freed
+ {
+ # in this particular case these are not the warnings we are looking for
+ local $SIG{__WARN__} = sigwarn_silencer qr/implementing the so called null-object-pattern/;
+
+ # if is inside the eval, to clear $@ in the undef case
+ eval { die $pre_poison if defined $pre_poison };
+
+ my $guard = $schema->txn_scope_guard;
+
+ eval { die $post_poison if defined $post_poison };
+
+ $schema->resultset ('Artist')->create ({ name => "bohhoo, too bad we'll roll you back"});
+ }
+
+ local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...'
+ if ( defined $post_poison and (
+ # take no chances on installation
+ DBICTest::RunMode->is_plain
+ or
+ # I do not understand why but on <= 5.8.8 and on 5.10.0
+ # "$pre_poison == $post_poison == string" passes...
+ # so todoify 5.8.9 and 5.10.1+, and deal with the rest below
+ ( ( "$]" > 5.008008 and "$]" < 5.010000 ) or "$]" > 5.010000 )
+ or
+ ! defined $pre_poison
+ or
+ length ref $pre_poison
+ or
+ length ref $post_poison
+ ));
+
+ is (@w, 2, sprintf 'Both expected warnings found - $@ poisonstate: pre-poison:%s post-poison:%s',
+ map {
+ ! defined $_ ? 'UNDEF'
+ : ! length ref $_ ? $_
+ : ref $_
+
+ } ($pre_poison, $post_poison)
+ );
+
+ # just to mask off warning since we could not disconnect above
+ $schema->storage->_dbh->disconnect;
+ }
+ }
+}
# add a TODO to catch when Text::Balanced is finally fixed
# https://rt.cpan.org/Public/Bug/Display.html?id=74994
my @w;
local $SIG{__WARN__} = sub {
- $_[0] =~ /External exception object .+? \Qimplements partial (broken) overloading/
+ $_[0] =~ /External exception class .+? \Qimplements partial (broken) overloading/
? push @w, @_
: warn @_
};
lives_ok {
# this is what poisons $@
Text::Balanced::extract_bracketed( '(foo', '()' );
+ DBIx::Class::_Util::is_exception($@);
my $s = DBICTest::Schema->connect('dbi:SQLite::memory:');
my $g = $s->txn_scope_guard;
is(scalar @w, 0, 'no warnings \o/');
}
+# ensure Devel::StackTrace-refcapture-like effects are countered
+{
+ my $s = DBICTest::Schema->connect('dbi:SQLite::memory:');
+ my $g = $s->txn_scope_guard;
+
+ my @arg_capture;
+ {
+ local $SIG{__WARN__} = sub {
+ package DB;
+ my $frnum;
+ while (my @f = CORE::caller(++$frnum) ) {
+ push @arg_capture, @DB::args;
+ }
+ };
+
+ undef $g;
+ 1;
+ }
+
+ warnings_exist
+ { @arg_capture = () }
+ qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/
+ ;
+}
+
done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More 'no_plan';
+use lib 't/lib';
+use DBICTest::RunMode;
+
+my $authorcount = scalar do {
+ open (my $fh, '<', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n";
+ map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>;
+} or die "Known AUTHORS file seems empty... can't happen...";
+
+# do not announce anything under ci - we are watching for STDERR silence
+diag <<EOD unless DBICTest::RunMode->is_ci;
+
+
+
+$authorcount contributors made this library what it is today
+
+
+Distinguished patrons:
+ * ( 2014 ~ 2015 ) Henry Van Styn, creator of http://p3rl.org/RapidApp
+
+
+EOD
+
+# looks funny if we do it before stuff
+ok 1;
}
sub _possibly_has_bad_overload_performance {
- return $] < 5.008009 && !_has_bug_34925();
+ return( "$]" < 5.008009 and !_has_bug_34925() );
}
# If this next one fails then you almost certainly have a RH derived
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use Config;
+use File::Spec;
+
+my @known_authors = do {
+ # according to #p5p this is how one safely reads random unicode
+ # this set of boilerplate is insane... wasn't perl unicode-king...?
+ no warnings 'once';
+ require Encode;
+ require PerlIO::encoding;
+ local $PerlIO::encoding::fallback = Encode::FB_CROAK();
+
+ open (my $fh, '<:encoding(UTF-8)', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n";
+ map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>;
+
+} or die "Known AUTHORS file seems empty... can't happen...";
+
+is_deeply (
+ [ grep { /^\s/ or /\s\s/ } @known_authors ],
+ [],
+ "No entries with leading or doubled space",
+);
+
+is_deeply (
+ [ grep { / \:[^\s\/] /x or /^ [^:]*? \s+ \: /x } @known_authors ],
+ [],
+ "No entries with malformed nicks",
+);
+
+is_deeply (
+ \@known_authors,
+ [ sort { lc $a cmp lc $b } @known_authors ],
+ 'Author list is case-insensitively sorted'
+);
+
+my $email_re = qr/( \< [^\<\>]+ \> ) $/x;
+
+my %known_authors;
+for (@known_authors) {
+ my ($name_email) = m/ ^ (?: [^\:]+ \: \s )? (.+) /x;
+ my ($email) = $name_email =~ $email_re;
+
+ fail "Duplicate found: $name_email" if (
+ $known_authors{$name_email}++
+ or
+ ( $email and $known_authors{$email}++ )
+ );
+}
+
+# augh taint mode
+if (length $ENV{PATH}) {
+ ( $ENV{PATH} ) = join ( $Config{path_sep},
+ map { length($_) ? File::Spec->rel2abs($_) : () }
+ split /\Q$Config{path_sep}/, $ENV{PATH}
+ ) =~ /\A(.+)\z/;
+}
+
+# no git-check when smoking a PR
+if (
+ (
+ ! $ENV{TRAVIS_PULL_REQUEST}
+ or
+ $ENV{TRAVIS_PULL_REQUEST} eq "false"
+ )
+ and
+ -d '.git'
+) {
+
+ binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
+
+ # this may fail - not every system has git
+ for (
+ map
+ { my ($gitname) = m/^ \s* \d+ \s* (.+?) \s* $/mx; utf8::decode($gitname); $gitname }
+ qx( git shortlog -e -s )
+ ) {
+ my ($eml) = $_ =~ $email_re;
+
+ ok $known_authors{$eml},
+ "Commit author '$_' (from .mailmap-aware `git shortlog -e -s`) reflected in ./AUTHORS";
+ }
+}
+
+done_testing;
use warnings;
use strict;
+BEGIN { delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} }
+
use DBIx::Class::_Util 'sigwarn_silencer';
use if DBIx::Class::_ENV_::BROKEN_FORK, 'threads';
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_podcoverage';
+
use warnings;
use strict;
use Test::More;
use List::Util 'first';
+use Module::Runtime 'require_module';
use lib qw(t/lib maint/.Generated_Pod/lib);
use DBICTest;
use namespace::clean;
-require DBIx::Class;
-unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_podcoverage') ) {
- my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_podcoverage');
- $ENV{RELEASE_TESTING}
- ? die ("Failed to load release-testing module requirements: $missing")
- : plan skip_all => "Test needs: $missing"
-}
-
# this has already been required but leave it here for CPANTS static analysis
require Test::Pod::Coverage;
mk_classaccessor
/]
},
+ 'DBIx::Class::Optional::Dependencies' => {
+ ignore => [qw/
+ croak
+ /]
+ },
'DBIx::Class::Carp' => {
ignore => [qw/
unimport
store_column
get_column
get_columns
+ has_column_loaded
/],
},
'DBIx::Class::ResultSource' => {
skip ("$module exempt", 1) if ($ex->{skip});
+ skip ("$module not loadable", 1) unless eval { require_module($module) };
+
# build parms up from ignore list
my $parms = {};
$parms->{trustme} =
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use File::Find;
+
+my $boilerplate_headings = q{
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+};
+
+find({
+ wanted => sub {
+ my $fn = $_;
+
+ return unless -f $fn;
+ return unless $fn =~ / \. (?: pm | pod ) $ /ix;
+
+ my $data = do { local (@ARGV, $/) = $fn; <> };
+
+ if ($data !~ /^=head1 NAME/m) {
+
+ # the generator is full of false positives, .pod is where it's at
+ return if $fn =~ qr{\Qlib/DBIx/Class/Optional/Dependencies.pm};
+
+ ok ( $data !~ /\bcopyright\b/i, "No copyright notices in $fn without apparent POD" );
+ }
+ elsif ($fn =~ qr{\Qlib/DBIx/Class.}) {
+ # nothing to check there - a static set of words
+ }
+ else {
+ ok ( $data !~ / ^ =head1 \s $_ /xmi, "No standalone $_ headings in $fn" )
+ for qw(AUTHOR CONTRIBUTOR LICENSE LICENCE);
+
+ ok ( $data !~ / ^ =head1 \s COPYRIGHT \s (?! AND \s LICENSE )/xmi, "No standalone COPYRIGHT headings in $fn" );
+
+ ok ($data =~ / \Q$boilerplate_headings\E (?! .*? ^ =head )/xms, "Expected headings found at the end of $fn");
+ }
+ },
+ no_chdir => 1,
+}, (qw(lib examples)) );
+
+done_testing;
--- /dev/null
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_pod';
+
+use warnings;
+use strict;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+# this has already been required but leave it here for CPANTS static analysis
+require Test::Pod;
+
+my $generated_pod_dir = 'maint/.Generated_Pod';
+Test::Pod::all_pod_files_ok( 'lib', -d $generated_pod_dir ? $generated_pod_dir : () );
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_whitespace';
+
use warnings;
use strict;
use lib 't/lib';
use DBICTest ':GlobalLock';
-require DBIx::Class;
-unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_whitespace') ) {
- my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_whitespace');
- $ENV{RELEASE_TESTING}
- ? die ("Failed to load release-testing module requirements: $missing")
- : plan skip_all => "Test needs: $missing"
-}
-
# FIXME - temporary workaround for RT#82032, RT#82033
# also add all scripts (no extension) and some extra extensions
# we want to check
--- /dev/null
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_strictures';
+
+use warnings;
+use strict;
+
+use Test::More;
+use File::Find;
+use File::Spec;
+use Config;
+use lib 't/lib';
+use DBICTest;
+
+# The rationale is - if we can load all our optdeps
+# that are related to lib/ - then we should be able to run
+# perl -c checks (via syntax_ok), and all should just work
+my $missing_groupdeps_present = grep
+ { ! DBIx::Class::Optional::Dependencies->req_ok_for($_) }
+ grep
+ { $_ !~ /^ (?: test | rdbms | dist ) _ /x }
+ keys %{DBIx::Class::Optional::Dependencies->req_group_list}
+;
+
+# don't test syntax when RT#106935 is triggered (mainly CI)
+# FIXME - remove when RT is resolved
+my $tainted_relpath = (
+ length $ENV{PATH}
+ and
+ ${^TAINT}
+ and
+ grep
+ { ! File::Spec->file_name_is_absolute($_) }
+ split /\Q$Config{path_sep}/, $ENV{PATH}
+) ? 1 : 0;
+
+find({
+ wanted => sub {
+ -f $_ or return;
+ m/\.(?: pm | pl | t )$ /ix or return;
+
+ return if m{^(?:
+ maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured
+ |
+ t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive)
+ |
+ lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load spee sensitive)
+ )$}x;
+
+ my $f = $_;
+
+ Test::Strict::strict_ok($f);
+ Test::Strict::warnings_ok($f);
+
+ Test::Strict::syntax_ok($f) if (
+ ! $tainted_relpath
+ and
+ ! $missing_groupdeps_present
+ and
+ $f =~ /^ (?: lib )/x
+ );
+ },
+ no_chdir => 1,
+}, (qw(lib t examples maint)) );
+
+done_testing;
'Correct method picked'
);
-if ($] >= 5.010) {
+if ( "$]" >= 5.010 ) {
ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+');
# Class::C3::Componentised loads MRO::Compat unconditionally to satisfy
-# vim: filetype=perl
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script';
+
use strict;
use warnings;
+BEGIN {
+ # just in case the user env has stuff in it
+ delete $ENV{JSON_ANY_ORDER};
+ delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY};
+}
+
use Test::More;
use Config;
use File::Spec;
use lib qw(t/lib);
use DBICTest;
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' .
- DBIx::Class::Optional::Dependencies->req_missing_for('test_admin_script')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('test_admin_script');
-
- # just in case the user env has stuff in it
- delete $ENV{JSON_ANY_ORDER};
-}
-
$ENV{PATH} = '';
$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
-require JSON::Any;
my @json_backends = qw(DWIW PP JSON CPANEL XS);
# test the script is setting @INC properly
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest::Schema::Artist;
+
+my $pkg = 'DBICTest::Schema::Artist';
+
+for my $call (qw(has_many might_have has_one belongs_to)) {
+ {
+ local $TODO = 'stupid stupid heuristic - needs to die'
+ if $call eq 'belongs_to';
+
+ throws_ok {
+ $pkg->$call( foos => 'nonexistent bars', { foo => 'self.artistid' } );
+ } qr/Malformed relationship condition key 'foo': must be prefixed with 'foreign.'/,
+ "Correct exception on $call with malformed foreign.";
+ }
+
+ throws_ok {
+ $pkg->has_many( foos => 'nonexistent bars', { 'foreign.foo' => 'name' } );
+ } qr/\QMalformed relationship condition value 'name': must be prefixed with 'self.'/,
+ "Correct exception on $call with malformed self.";
+}
+
+done_testing;
use DBICTest;
use Test::More;
-plan tests => 15;
-
my $schema = DBICTest->init_schema();
my $rs = $schema->resultset( 'CD' );
is_deeply( $result, $expected );
}
+{
+ my $a = [ { 'artist' => { 'manager' => {} } }, 'cd' ];
+ my $b = [ 'artist', { 'artist' => { 'manager' => {} } } ];
+ my $expected = [ { 'artist' => { 'manager' => {} } }, 'cd', { 'artist' => { 'manager' => {} } } ];
+ my $result = $rs->_merge_joinpref_attr($a, $b);
+ is_deeply( $result, $expected );
+}
+
+{
+ my $a = [ { 'artist' => { 'manager' => undef } }, 'cd' ];
+ my $b = [ 'artist', { 'artist' => { 'manager' => undef } } ];
+ my $expected = [ { 'artist' => { 'manager' => undef } }, 'cd', { 'artist' => { 'manager' => undef } } ];
+ my $result = $rs->_merge_joinpref_attr($a, $b);
+ is_deeply( $result, $expected );
+}
-1;
+done_testing;
BEGIN {
- if ($] < 5.010) {
+ if ( "$]" < 5.010) {
# Pre-5.10 perls pollute %INC on unsuccesfull module
# require, making it appear as if the module is already
use Test::More;
use lib 't/lib';
-use DBICTest;
+use DBICTest;
use File::Find;
use File::Spec;
use B qw/svref_2object/;
'DBIx::Class::ResultSet::Pager',
# utility classes, not part of the inheritance chain
+ 'DBIx::Class::Optional::Dependencies',
'DBIx::Class::ResultSource::RowParser::Util',
'DBIx::Class::_Util',
) };
my $has_moose = eval { require Moose::Util };
+Sub::Defer::undefer_all();
+
# can't use Class::Inspector for the mundane parts as it does not
# distinguish imports from anything else, what a crock of...
# Moose is not always available either - hence just do it ourselves
last;
}
}
- fail ("${mod}::${name} appears to have entered inheritance chain by import into "
- . ($via || 'UNKNOWN')
- );
+
+ # exception time
+ if (
+ ( $name eq 'import' and $via = 'Exporter' )
+ ) {
+ pass("${mod}::${name} is a valid uncleaned import from ${name}");
+ }
+ else {
+ fail ("${mod}::${name} appears to have entered inheritance chain by import into "
+ . ($via || 'UNKNOWN')
+ );
+ }
}
}
sub find_modules {
my @modules;
- find({
+ find( {
wanted => sub {
-f $_ or return;
s/\.pm$// or return;
push @modules, join ('::', File::Spec->splitdir($_));
},
no_chdir => 1,
- }, (-e 'blib' ? 'blib' : 'lib') );
+ }, (
+ # find them in both lib and blib, duplicates are fine, since
+ # @INC is preadjusted for us by the harness
+ 'lib',
+ ( -e 'blib' ? 'blib' : () ),
+ ));
return sort @modules;
}
--- /dev/null
+my ($inc_before, $inc_after);
+BEGIN {
+ $inc_before = [ keys %INC ];
+ require DBIx::Class::Optional::Dependencies;
+ $inc_after = [ keys %INC ];
+}
+
+use strict;
+use warnings;
+no warnings qw/once/;
+
+use Test::More;
+use Test::Exception;
+
+# load before we break require()
+use Scalar::Util();
+use MRO::Compat();
+use Carp 'confess';
+use List::Util 'shuffle';
+
+SKIP: {
+ skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 if $ENV{PERL5OPT};
+ skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 if $ENV{RELEASE_TESTING};
+ is_deeply
+ $inc_before,
+ [],
+ 'Nothing was loaded before inc-test'
+ ;
+ is_deeply
+ $inc_after,
+ [ 'DBIx/Class/Optional/Dependencies.pm' ],
+ 'Nothing was loaded other than DBIx::Class::OptDeps'
+ ;
+}
+
+# check the project-local groups for sanity
+lives_ok {
+ DBIx::Class::Optional::Dependencies->req_group_list
+} "The entire optdep list is well formed";
+
+is_deeply (
+ [ keys %{ DBIx::Class::Optional::Dependencies->req_list_for ('deploy') } ],
+ [ 'SQL::Translator' ],
+ 'Correct deploy() dependency list',
+);
+
+# scope to break require()
+{
+
+# make module loading impossible, regardless of actual libpath contents
+ local @INC;
+
+# basic test using the deploy target
+ for ('deploy', ['deploy']) {
+
+ # explicitly blow up cache
+ %DBIx::Class::Optional::Dependencies::req_unavailability_cache = ();
+
+ ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ($_),
+ 'deploy() deps missing',
+ );
+
+ like (
+ DBIx::Class::Optional::Dependencies->modreq_missing_for ($_),
+ qr/
+ \A
+ SQL::Translator \~ [\d\.]+
+ \z
+ /x,
+ 'expected modreq missing string contents',
+ );
+
+ like (
+ DBIx::Class::Optional::Dependencies->req_missing_for ($_),
+ qr/
+ \A
+ SQL::Translator \~ [\d\.]+
+ \Q (see DBIx::Class::Optional::Dependencies documentation for details)\E
+ \z
+ /x,
+ 'expected missing string contents',
+ );
+
+ like (
+ DBIx::Class::Optional::Dependencies->modreq_errorlist_for ($_)->{'SQL::Translator'},
+ qr|\QCan't locate SQL/Translator.pm|,
+ 'correct "unable to locate" exception found in errorlist',
+ );
+
+ #make it so module appears loaded
+ local $INC{'SQL/Translator.pm'} = 1;
+ local $SQL::Translator::VERSION = 999;
+
+ ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ($_),
+ 'deploy() deps missing cached properly from previous run',
+ );
+
+ # blow cache again
+ %DBIx::Class::Optional::Dependencies::req_unavailability_cache = ();
+
+ ok (
+ DBIx::Class::Optional::Dependencies->req_ok_for ($_),
+ 'deploy() deps present',
+ );
+
+ is (
+ DBIx::Class::Optional::Dependencies->req_missing_for ($_),
+ '',
+ 'expected null missing string',
+ );
+
+ is_deeply (
+ # use the deprecated method name
+ DBIx::Class::Optional::Dependencies->req_errorlist_for ($_),
+ undef,
+ 'expected empty errorlist',
+ );
+ }
+
+# test single-db text
+ local $ENV{DBICTEST_MYSQL_DSN};
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_mysql'),
+ undef,
+ 'unknown optional dependencies list for testing MySQL without ENV var',
+ );
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->modreq_list_for('test_rdbms_mysql'),
+ { 'DBD::mysql' => 0 },
+ 'correct optional module dependencies list for testing MySQL without ENV var',
+ );
+
+ local $ENV{DBICTEST_MYSQL_DSN};
+ local $ENV{DBICTEST_PG_DSN};
+
+# regular
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->modreq_list_for([shuffle qw( test_rdbms_pg binary_data )]),
+ { 'DBD::Pg' => '2.009002' },
+ 'optional dependencies list for testing Postgres without envvar',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for([shuffle qw( test_rdbms_pg binary_data )]),
+ undef,
+ 'optional dependencies list for testing Postgres without envvar',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for('rdbms_pg'),
+ { 'DBD::Pg' => '0', },
+ 'optional dependencies list for using Postgres matches',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_missing_for('rdbms_pg'),
+ 'DBD::Pg (see DBIx::Class::Optional::Dependencies documentation for details)',
+ 'optional dependencies missing list for using Postgres matches',
+ );
+
+# test combination of different requirements on same module (pg's are relatively stable)
+ is_deeply (
+ DBIx::Class::Optional::Dependencies->req_list_for([shuffle qw( rdbms_pg test_rdbms_pg )]),
+ { 'DBD::Pg' => '0' },
+ 'optional module dependencies list for testing Postgres matches without envvar',
+ );
+
+ is(
+ DBIx::Class::Optional::Dependencies->req_missing_for([shuffle qw( rdbms_pg test_rdbms_pg binary_data )]),
+ 'DBD::Pg~2.009002 as well as the following group(s) of environment variables: DBICTEST_PG_DSN/..._USER/..._PASS',
+ 'optional dependencies for testing Postgres without envvar'
+ );
+
+ is(
+ DBIx::Class::Optional::Dependencies->req_missing_for([shuffle qw( test_rdbms_mysql test_rdbms_pg binary_data)]),
+ 'DBD::mysql DBD::Pg~2.009002 as well as the following group(s) of environment variables: DBICTEST_MYSQL_DSN/..._USER/..._PASS and DBICTEST_PG_DSN/..._USER/..._PASS',
+ 'optional dependencies for testing Postgres+MySQL without envvars'
+ );
+
+ $ENV{DBICTEST_PG_DSN} = 'boo';
+ is_deeply (
+ DBIx::Class::Optional::Dependencies->modreq_list_for([shuffle qw( rdbms_pg test_rdbms_pg binary_data)]),
+ { 'DBD::Pg' => '2.009002' },
+ 'optional module dependencies list for testing Postgres matches with envvar',
+ );
+
+ is(
+ DBIx::Class::Optional::Dependencies->req_missing_for([shuffle qw( rdbms_pg test_rdbms_pg binary_data )]),
+ 'DBD::Pg~2.009002',
+ 'optional dependencies error text for testing Postgres matches with evvar',
+ );
+
+# ICDT augmentation
+ my %expected_icdt_base = ( DateTime => '0.55', 'DateTime::TimeZone::OlsonDB' => 0 );
+
+ my $mysql_icdt = [shuffle qw( test_rdbms_mysql ic_dt )];
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->modreq_list_for($mysql_icdt),
+ {
+ %expected_icdt_base,
+ 'DBD::mysql' => 0,
+ 'DateTime::Format::MySQL' => 0,
+ },
+ 'optional module dependencies list for testing ICDT MySQL without envvar',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for($mysql_icdt),
+ \%expected_icdt_base,
+ 'optional dependencies list for testing ICDT MySQL without envvar',
+ );
+
+ is(
+ DBIx::Class::Optional::Dependencies->req_missing_for($mysql_icdt),
+ "DateTime~0.55 DateTime::Format::MySQL DateTime::TimeZone::OlsonDB DBD::mysql as well as the following group(s) of environment variables: DBICTEST_MYSQL_DSN/..._USER/..._PASS",
+ 'missing optional dependencies for testing ICDT MySQL without envvars'
+ );
+
+# test multi-level include with a variable and mandatory part converging on same included dep
+ local $ENV{DBICTEST_MSACCESS_ODBC_DSN};
+ local $ENV{DBICTEST_MSSQL_ODBC_DSN} = 'foo';
+ my $msaccess_mssql_icdt = [ shuffle qw( test_rdbms_msaccess_odbc test_rdbms_mssql_odbc ic_dt ) ];
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_missing_for($msaccess_mssql_icdt),
+ 'Data::GUID DateTime~0.55 DateTime::Format::Strptime~1.2 DateTime::TimeZone::OlsonDB DBD::ODBC as well as the following group(s) of environment variables: DBICTEST_MSACCESS_ODBC_DSN/..._USER/..._PASS',
+ 'Correct req_missing_for on multi-level converging include',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->modreq_missing_for($msaccess_mssql_icdt),
+ 'Data::GUID DateTime~0.55 DateTime::Format::Strptime~1.2 DateTime::TimeZone::OlsonDB DBD::ODBC',
+ 'Correct modreq_missing_for on multi-level converging include',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for($msaccess_mssql_icdt),
+ {
+ 'DBD::ODBC' => 0,
+ 'DateTime::Format::Strptime' => '1.2',
+ %expected_icdt_base,
+ },
+ 'Correct req_list_for on multi-level converging include',
+ );
+
+ is_deeply(
+ DBIx::Class::Optional::Dependencies->modreq_list_for($msaccess_mssql_icdt),
+ {
+ 'DBD::ODBC' => 0,
+ 'Data::GUID' => 0,
+ 'DateTime::Format::Strptime' => '1.2',
+ %expected_icdt_base,
+ },
+ 'Correct modreq_list_for on multi-level converging include',
+ );
+
+}
+
+# test multiple times to find autovivification bugs
+for my $meth (qw(req_list_for modreq_list_for)) {
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->$meth();
+ } qr/\Qreq_list_for() expects a requirement group name/,
+ "$meth without groupname throws exception";
+
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->$meth('');
+ } qr/\Q$meth() expects a requirement group name/,
+ "$meth with empty groupname throws exception";
+
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->$meth('invalid_groupname');
+ } qr/Requirement group 'invalid_groupname' is not defined/,
+ "$meth with invalid groupname throws exception";
+}
+
+done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use Test::Warn;
+
+use DBIx::Class::_Util 'quote_sub';
+
+my $q = do {
+ no strict 'vars';
+ quote_sub '$x = $x . "buh"; $x += 42';
+};
+
+warnings_exist {
+ is $q->(), 42, 'Expected result after uninit and string/num conversion'
+} [
+ qr/Use of uninitialized value/i,
+ qr/isn't numeric in addition/,
+], 'Expected warnings, strict did not leak inside the qsub'
+ or do {
+ require B::Deparse;
+ diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($q) ) )
+ }
+;
+
+my $no_nothing_q = do {
+ no strict;
+ no warnings;
+ quote_sub <<'EOC';
+ BEGIN { warn "-->${^WARNING_BITS}<--\n" };
+ my $n = "Test::Warn::warnings_exist";
+ warn "-->@{[ *{$n}{CODE} ]}<--\n";
+EOC
+};
+
+my $we_cref = Test::Warn->can('warnings_exist');
+
+warnings_exist { $no_nothing_q->() } [
+ qr/^\-\-\>\0+\<\-\-$/m,
+ qr/^\Q-->$we_cref<--\E$/m,
+], 'Expected warnings, strict did not leak inside the qsub'
+ or do {
+ require B::Deparse;
+ diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($no_nothing_q) ) )
+ }
+;
+
+done_testing;
# these envvars *will* bring in more stuff than the baseline
delete @ENV{qw(DBICTEST_SQLT_DEPLOY DBIC_TRACE)};
+ # make sure extras do not load even when this is set
+ $ENV{PERL_STRICTURES_EXTRA} = 1;
+
unshift @INC, 't/lib';
require DBICTest::Util::OverrideRequire;
CORE::require('Test/More.pm');
Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])");
- if ($ENV{TEST_VERBOSE}) {
- CORE::require('DBICTest/Util.pm');
- Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() );
- }
+ CORE::require('DBICTest/Util.pm');
+ Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() );
}
return $res;
if $ENV{PERL5OPT};
plan skip_all => 'Dependency load patterns are radically different before perl 5.10'
- if $] < 5.010;
+ if "$]" < 5.010;
# add what we loaded so far
for (keys %INC) {
}
}
+BEGIN {
+ delete $ENV{$_} for qw(
+ DBICTEST_VIA_REPLICATED
+ DBICTEST_DEBUG_CONCURRENCY_LOCKS
+ );
+}
+
#######
### This is where the test starts
#######
namespace::clean
Try::Tiny
Sub::Name
+ Sub::Defer
+ Sub::Quote
Scalar::Util
List::Util
- Data::Compare
+ Storable
Class::Accessor::Grouped
Class::C3::Componentised
+ SQL::Abstract
));
require DBICTest::Schema;
{
register_lazy_loadable_requires(qw(
Moo
- Sub::Quote
+ Moo::Object
+ Method::Generate::Accessor
+ Method::Generate::Constructor
Context::Preserve
));
{
register_lazy_loadable_requires(qw(
DBI
- SQL::Abstract
Hash::Merge
));
my $nl;
for my $mod (keys %$expected_dbic_deps) {
(my $modfn = "$mod.pm") =~ s/::/\//g;
- unless ($INC{$modfn}) {
- my $err = sprintf "Expected DBIC core dependency '%s' never loaded - %s needs adjustment", $mod, __FILE__;
- if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) {
- fail ($err)
- }
- else {
- diag "\n" unless $nl->{$mod}++;
- diag $err;
- }
- }
+ fail sprintf (
+ "Expected DBIC core dependency '%s' never loaded - %s needs adjustment",
+ $mod,
+ __FILE__
+ ) unless $INC{$modfn};
}
pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s',
__FILE__,
use warnings;
use Test::More;
+use Test::Exception;
+use File::Temp ();
use lib 't/lib';
-use DBICTest::RunMode;
-
-if ( DBICTest::RunMode->is_plain ) {
- plan( skip_all => "Skipping test on plain module install" );
-}
-
-use Test::Exception;
use DBICTest;
-use File::Temp ();
plan tests => 2;
my $wait_for = 120; # how many seconds to wait
-#!/usr/bin/perl
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy';
use strict;
use warnings;
use ViewDeps;
use ViewDepsBad;
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' .
- DBIx::Class::Optional::Dependencies->req_missing_for('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
-}
-
-use_ok('DBIx::Class::ResultSource::View');
-
#################### SANITY
my $view = DBIx::Class::ResultSource::View->new;
= ViewDepsBad->connect( DBICTest->_database ( quote_char => '"') );
ok( $schema2, 'Connected to ViewDepsBad schema OK' );
+ my $lazy_view_validity = !(
+ $schema2->storage->_server_info->{normalized_dbms_version}
+ <
+ 3.009
+ );
+
#################### DEPLOY2
warnings_exist { $schema2->deploy }
- [qr/no such table: main.aba_name_artists/],
+ [ $lazy_view_validity ? () : qr/no such table: main.aba_name_artists/ ],
"Deploying the bad schema produces a warning: aba_name_artists was not created.";
#################### DOES ORDERING WORK 2?
} grep { !/AbaNameArtistsAnd2010CDsWithManyTracks/ }
@{ [ $schema2->sources ] };
+ $schema2->storage->dbh->do(q( DROP VIEW "aba_name_artists" ))
+ if $lazy_view_validity;
+
throws_ok { $schema2->resultset('AbaNameArtistsAnd2010CDsWithManyTracks')->next }
- qr/no such table: aba_name_artists_and_2010_cds_with_many_tracks/,
- "Query on AbaNameArtistsAnd2010CDsWithManyTracks throws, because the table does not exist"
+ qr/no such table: (?:main\.)?aba_name_artists/,
+ sprintf(
+ "Query on AbaNameArtistsAnd2010CDsWithManyTracks throws, because the%s view does not exist",
+ $lazy_view_validity ? ' underlying' : ''
+ )
;
}
+++ /dev/null
-use strict;
-use warnings;
-no warnings qw/once/;
-
-use Test::More;
-use Test::Exception;
-use lib qw(t/lib);
-use Scalar::Util; # load before we break require()
-use Carp (); # Carp is not used in the test, but we want to have it loaded for proper %INC comparison
-
-# a dummy test which lazy-loads more modules (so we can compare INC below)
-ok (1);
-
-# record contents of %INC - makes sure there are no extra deps slipping into
-# Opt::Dep.
-my $inc_before = [ keys %INC ];
-ok ( (! grep { $_ =~ m|DBIx/Class| } @$inc_before ), 'Nothing DBIC related is yet loaded');
-
-# DBIx::Class::Optional::Dependencies queries $ENV at compile time
-# to build the optional requirements
-BEGIN {
- $ENV{DBICTEST_PG_DSN} = '1';
- delete $ENV{DBICTEST_ORA_DSN};
-}
-
-use_ok 'DBIx::Class::Optional::Dependencies';
-
-my $inc_after = [ keys %INC ];
-
-is_deeply (
- [ sort @$inc_after],
- [ sort (@$inc_before, 'DBIx/Class/Optional/Dependencies.pm') ],
- 'Nothing loaded other than DBIx::Class::OptDeps',
-);
-
-my $sqlt_dep = DBIx::Class::Optional::Dependencies->req_list_for ('deploy');
-is_deeply (
- [ keys %$sqlt_dep ],
- [ 'SQL::Translator' ],
- 'Correct deploy() dependency list',
-);
-
-# make module loading impossible, regardless of actual libpath contents
-{
- local @INC = (sub { die('Optional Dep Test') } );
-
- ok (
- ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps missing',
- );
-
- like (
- DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
- qr/^SQL::Translator \>\= \d/,
- 'expected missing string contents',
- );
-
- like (
- DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy')->{'SQL::Translator'},
- qr/Optional Dep Test/,
- 'custom exception found in errorlist',
- );
-}
-
-#make it so module appears loaded
-$INC{'SQL/Translator.pm'} = 1;
-$SQL::Translator::VERSION = 999;
-
-ok (
- ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps missing cached properly',
-);
-
-#reset cache
-%DBIx::Class::Optional::Dependencies::req_availability_cache = ();
-
-
-ok (
- DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps present',
-);
-
-is (
- DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
- '',
- 'expected null missing string',
-);
-
-is_deeply (
- DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy'),
- {},
- 'expected empty errorlist',
-);
-
-# test multiple times to find autovivification bugs
-for (1..2) {
- throws_ok {
- DBIx::Class::Optional::Dependencies->req_list_for();
- } qr/\Qreq_list_for() expects a requirement group name/,
- "req_list_for without groupname throws exception on run $_";
-
- throws_ok {
- DBIx::Class::Optional::Dependencies->req_list_for('');
- } qr/\Qreq_list_for() expects a requirement group name/,
- "req_list_for with empty groupname throws exception on run $_";
-
- throws_ok {
- DBIx::Class::Optional::Dependencies->req_list_for('invalid_groupname');
- } qr/Requirement group 'invalid_groupname' does not exist/,
- "req_list_for with invalid groupname throws exception on run $_";
-}
-
-is_deeply(
- DBIx::Class::Optional::Dependencies->req_list_for('rdbms_pg'),
- {
- 'DBD::Pg' => '0',
- }, 'optional dependencies for deploying to Postgres ok');
-
-is_deeply(
- DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_pg'),
- {
- $^O ne 'MSWin32' ? ('Sys::SigAction' => '0') : (),
- 'DBD::Pg' => '2.009002',
- }, 'optional dependencies for testing Postgres with ENV var ok');
-
-is_deeply(
- DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_oracle'),
- {}, 'optional dependencies for testing Oracle without ENV var ok');
-
-done_testing;
+++ /dev/null
-use warnings;
-use strict;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-require DBIx::Class;
-unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) {
- my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_pod');
- $ENV{RELEASE_TESTING}
- ? die ("Failed to load release-testing module requirements: $missing")
- : plan skip_all => "Test needs: $missing"
-}
-
-# this has already been required but leave it here for CPANTS static analysis
-require Test::Pod;
-
-my $generated_pod_dir = 'maint/.Generated_Pod';
-Test::Pod::all_pod_files_ok( 'lib', -d $generated_pod_dir ? $generated_pod_dir : () );
+++ /dev/null
-use warnings;
-use strict;
-
-use Test::More;
-use lib 't/lib';
-use DBICTest;
-
-unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_strictures') ) {
- my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_strictures');
- $ENV{RELEASE_TESTING}
- ? die ("Failed to load release-testing module requirements: $missing")
- : plan skip_all => "Test needs: $missing"
-}
-
-
-use File::Find;
-
-find({
- wanted => sub {
- -f $_ or return;
- m/\.(?: pm | pl | t )$ /ix or return;
-
- return if m{^(?:
- maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured
- |
- t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive)
- )$}x;
-
- my $f = $_;
-
- Test::Strict::strict_ok($f);
- Test::Strict::warnings_ok($f);
-
- #Test::Strict::syntax_ok($f) if $f =~ /^ (?: lib )/x;
- },
- no_chdir => 1,
-}, (qw(lib t examples maint)) );
-
-done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff