1package Class::DBI::__::Base;
2
3require 5.006;
4
5use Class::Trigger 0.07;
6use base qw(Class::Accessor Class::Data::Inheritable Ima::DBI);
7
8package Class::DBI;
9
10use version; $VERSION = qv('3.0.17');
11
12use strict;
13use warnings;
14
15use base "Class::DBI::__::Base";
16
17use Class::DBI::ColumnGrouper;
18use Class::DBI::Query;
19use Carp ();
20use List::Util;
21use Clone ();
22use UNIVERSAL::moniker;
23
24use vars qw($Weaken_Is_Available);
25
26BEGIN {
27	$Weaken_Is_Available = 1;
28	eval {
29		require Scalar::Util;
30		import Scalar::Util qw(weaken);
31	};
32	if ($@) {
33		$Weaken_Is_Available = 0;
34	}
35}
36
37use overload
38	'""'     => sub { shift->stringify_self },
39	bool     => sub { not shift->_undefined_primary },
40	fallback => 1;
41
42sub stringify_self {
43	my $self = shift;
44	return (ref $self || $self) unless $self;    # empty PK
45	my @cols = $self->columns('Stringify');
46	@cols = $self->primary_columns unless @cols;
47	return join "/", $self->get(@cols);
48}
49
50sub _undefined_primary {
51	my $self = shift;
52	return grep !defined, $self->_attrs($self->primary_columns);
53}
54
55#----------------------------------------------------------------------
56# Deprecations
57#----------------------------------------------------------------------
58
59__PACKAGE__->mk_classdata('__hasa_rels' => {});
60
61{
62	my %deprecated = (
63   # accessor_name => 'accessor_name_for', # 3.0.7
64   # mutator_name  => 'accessor_name_for', # 3.0.7
65  );
66
67	no strict 'refs';
68	while (my ($old, $new) = each %deprecated) {
69		*$old = sub {
70			my @caller = caller;
71			warn
72				"Use of '$old' is deprecated at $caller[1] line $caller[2]. Use '$new' instead\n";
73			goto &$new;
74		};
75	}
76}
77
78#----------------------------------------------------------------------
79# Our Class Data
80#----------------------------------------------------------------------
81__PACKAGE__->mk_classdata('__AutoCommit');
82__PACKAGE__->mk_classdata('__hasa_list');
83__PACKAGE__->mk_classdata('_table');
84__PACKAGE__->mk_classdata('_table_alias');
85__PACKAGE__->mk_classdata('sequence');
86__PACKAGE__->mk_classdata('__grouper'   => Class::DBI::ColumnGrouper->new());
87__PACKAGE__->mk_classdata('__data_type' => {});
88__PACKAGE__->mk_classdata('__driver');
89__PACKAGE__->mk_classdata('iterator_class' => 'Class::DBI::Iterator');
90__PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
91__PACKAGE__->add_searcher(search => "Class::DBI::Search::Basic",);
92
93__PACKAGE__->add_relationship_type(
94	has_a      => "Class::DBI::Relationship::HasA",
95	has_many   => "Class::DBI::Relationship::HasMany",
96	might_have => "Class::DBI::Relationship::MightHave",
97);
98__PACKAGE__->mk_classdata('__meta_info' => {});
99
100#----------------------------------------------------------------------
101# SQL we'll need
102#----------------------------------------------------------------------
103__PACKAGE__->set_sql(MakeNewObj => <<'');
104INSERT INTO __TABLE__ (%s)
105VALUES (%s)
106
107__PACKAGE__->set_sql(update => <<"");
108UPDATE __TABLE__
109SET    %s
110WHERE  __IDENTIFIER__
111
112__PACKAGE__->set_sql(Nextval => <<'');
113SELECT NEXTVAL ('%s')
114
115__PACKAGE__->set_sql(SearchSQL => <<'');
116SELECT %s
117FROM   %s
118WHERE  %s
119
120__PACKAGE__->set_sql(RetrieveAll => <<'');
121SELECT __ESSENTIAL__
122FROM   __TABLE__
123
124__PACKAGE__->set_sql(Retrieve => <<'');
125SELECT __ESSENTIAL__
126FROM   __TABLE__
127WHERE  %s
128
129__PACKAGE__->set_sql(Flesh => <<'');
130SELECT %s
131FROM   __TABLE__
132WHERE  __IDENTIFIER__
133
134__PACKAGE__->set_sql(single => <<'');
135SELECT %s
136FROM   __TABLE__
137
138__PACKAGE__->set_sql(DeleteMe => <<"");
139DELETE
140FROM   __TABLE__
141WHERE  __IDENTIFIER__
142
143
144__PACKAGE__->mk_classdata('sql_transformer_class');
145__PACKAGE__->sql_transformer_class('Class::DBI::SQL::Transformer');
146
147# Override transform_sql from Ima::DBI to provide some extra
148# transformations
149sub transform_sql {
150	my ($self, $sql, @args) = @_;
151	my $tclass = $self->sql_transformer_class;
152	$self->_require_class($tclass);
153	my $T = $tclass->new($self, $sql, @args);
154	return $self->SUPER::transform_sql($T->sql => $T->args);
155}
156
157#----------------------------------------------------------------------
158# EXCEPTIONS
159#----------------------------------------------------------------------
160
161sub _carp {
162	my ($self, $msg) = @_;
163	Carp::carp($msg || $self);
164	return;
165}
166
167sub _croak {
168	my ($self, $msg) = @_;
169	Carp::croak($msg || $self);
170}
171
172sub _db_error {
173	my ($self, %info) = @_;
174	my $msg = delete $info{msg};
175	return $self->_croak($msg, %info);
176}
177
178#----------------------------------------------------------------------
179# SET UP
180#----------------------------------------------------------------------
181
182sub connection {
183	my $class = shift;
184	$class->set_db(Main => @_);
185}
186
187{
188	my %Per_DB_Attr_Defaults = (
189		pg     => { AutoCommit => 0 },
190		oracle => { AutoCommit => 0 },
191	);
192
193	sub _default_attributes {
194		my $class = shift;
195		return (
196			$class->SUPER::_default_attributes,
197			FetchHashKeyName   => 'NAME_lc',
198			ShowErrorStatement => 1,
199			AutoCommit         => 1,
200			ChopBlanks         => 1,
201			%{ $Per_DB_Attr_Defaults{ lc $class->__driver } || {} },
202		);
203	}
204}
205
206sub set_db {
207	my ($class, $db_name, $data_source, $user, $password, $attr) = @_;
208
209	# 'dbi:Pg:dbname=foo' we want 'Pg'. I think this is enough.
210	my ($driver) = $data_source =~ /^dbi:(\w+)/i;
211	$class->__driver($driver);
212	$class->SUPER::set_db('Main', $data_source, $user, $password, $attr);
213}
214
215sub table {
216	my ($proto, $table, $alias) = @_;
217	my $class = ref $proto || $proto;
218	$class->_table($table)      if $table;
219	$class->table_alias($alias) if $alias;
220	return $class->_table || $class->_table($class->table_alias);
221}
222
223sub table_alias {
224	my ($proto, $alias) = @_;
225	my $class = ref $proto || $proto;
226	$class->_table_alias($alias) if $alias;
227	return $class->_table_alias || $class->_table_alias($class->moniker);
228}
229
230sub columns {
231	my $proto = shift;
232	my $class = ref $proto || $proto;
233	my $group = shift || "All";
234	return $class->_set_columns($group => @_) if @_;
235	return $class->all_columns    if $group eq "All";
236	return $class->primary_column if $group eq "Primary";
237	return $class->_essential     if $group eq "Essential";
238	return $class->__grouper->group_cols($group);
239}
240
241sub _column_class { 'Class::DBI::Column' }
242
243sub _set_columns {
244	my ($class, $group, @columns) = @_;
245
246	my @cols = map ref $_ ? $_ : $class->_column_class->new($_), @columns;
247
248	# Careful to take copy
249	$class->__grouper(Class::DBI::ColumnGrouper->clone($class->__grouper)
250			->add_group($group => @cols));
251	$class->_mk_column_accessors(@cols);
252	return @columns;
253}
254
255sub all_columns { shift->__grouper->all_columns }
256
257sub id {
258	my $self  = shift;
259	my $class = ref($self)
260		or return $self->_croak("Can't call id() as a class method");
261
262	# we don't use get() here because all objects should have
263	# exisitng values for PK columns, or else loop endlessly
264	my @pk_values = $self->_attrs($self->primary_columns);
265	UNIVERSAL::can($_ => 'id') and $_ = $_->id for @pk_values;
266	return @pk_values if wantarray;
267	$self->_croak(
268		"id called in scalar context for class with multiple primary key columns")
269		if @pk_values > 1;
270	return $pk_values[0];
271}
272
273sub primary_column {
274	my $self            = shift;
275	my @primary_columns = $self->__grouper->primary;
276	return @primary_columns if wantarray;
277	$self->_carp(
278		ref($self)
279			. " has multiple primary columns, but fetching in scalar context")
280		if @primary_columns > 1;
281	return $primary_columns[0];
282}
283*primary_columns = \&primary_column;
284
285sub _essential { shift->__grouper->essential }
286
287sub find_column {
288	my ($class, $want) = @_;
289	return $class->__grouper->find_column($want);
290}
291
292sub _find_columns {
293	my $class = shift;
294	my $cg    = $class->__grouper;
295	return map $cg->find_column($_), @_;
296}
297
298sub has_real_column {    # is really in the database
299	my ($class, $want) = @_;
300	return ($class->find_column($want) || return)->in_database;
301}
302
303sub data_type {
304	my $class    = shift;
305	my %datatype = @_;
306	while (my ($col, $type) = each %datatype) {
307		$class->_add_data_type($col, $type);
308	}
309}
310
311sub _add_data_type {
312	my ($class, $col, $type) = @_;
313	my $datatype = $class->__data_type;
314	$datatype->{$col} = $type;
315	$class->__data_type($datatype);
316}
317
318# Make a set of accessors for each of a list of columns. We construct
319# the method name by calling accessor_name_for() and mutator_name_for()
320# with the normalized column name.
321
322# mutator name will be the same as accessor name unless you override it.
323
324# If both the accessor and mutator are to have the same method name,
325# (which will always be true unless you override mutator_name_for), a
326# read-write method is constructed for it. If they differ we create both
327# a read-only accessor and a write-only mutator.
328
329sub _mk_column_accessors {
330	my $class = shift;
331	foreach my $col (@_) {
332
333		my $default_accessor = $col->accessor;
334
335		my $acc = $class->accessor_name_for($col);
336		my $mut = $class->mutator_name_for($col);
337
338		my %method = ();
339
340		if (
341			($acc    eq $mut)                # if they are the same
342			or ($mut eq $default_accessor)
343			) {                              # or only the accessor was customized
344			%method = ('_' => $acc);         # make the accessor the mutator too
345			$col->accessor($acc);
346			$col->mutator($acc);
347			} else {
348			%method = (
349				_ro_ => $acc,
350				_wo_ => $mut,
351			);
352			$col->accessor($acc);
353			$col->mutator($mut);
354		}
355
356		foreach my $type (keys %method) {
357			my $name     = $method{$type};
358			my $acc_type = "make${type}accessor";
359			my $accessor = $class->$acc_type($col->name_lc);
360			$class->_make_method($_, $accessor) for ($name, "_${name}_accessor");
361		}
362	}
363}
364
365sub _make_method {
366	my ($class, $name, $method) = @_;
367	return if defined &{"$class\::$name"};
368	$class->_carp("Column '$name' in $class clashes with built-in method")
369		if Class::DBI->can($name)
370		and not($name eq "id" and join(" ", $class->primary_columns) eq "id");
371	no strict 'refs';
372	*{"$class\::$name"} = $method;
373	$class->_make_method(lc $name => $method);
374}
375
376sub accessor_name_for {
377	my ($class, $column) = @_;
378  if ($class->can('accessor_name')) {
379		warn "Use of 'accessor_name' is deprecated. Use 'accessor_name_for' instead\n";
380		return $class->accessor_name($column)
381	}
382	return $column->accessor;
383}
384
385sub mutator_name_for {
386	my ($class, $column) = @_;
387  if ($class->can('mutator_name')) {
388		warn "Use of 'mutator_name' is deprecated. Use 'mutator_name_for' instead\n";
389		return $class->mutator_name($column)
390	}
391	return $column->mutator;
392}
393
394sub autoupdate {
395	my $proto = shift;
396	ref $proto ? $proto->_obj_autoupdate(@_) : $proto->_class_autoupdate(@_);
397}
398
399sub _obj_autoupdate {
400	my ($self, $set) = @_;
401	my $class = ref $self;
402	$self->{__AutoCommit} = $set if defined $set;
403	defined $self->{__AutoCommit}
404		? $self->{__AutoCommit}
405		: $class->_class_autoupdate;
406}
407
408sub _class_autoupdate {
409	my ($class, $set) = @_;
410	$class->__AutoCommit($set) if defined $set;
411	return $class->__AutoCommit;
412}
413
414sub make_read_only {
415	my $proto = shift;
416	$proto->add_trigger("before_$_" => sub { _croak "$proto is read only" })
417		foreach qw/create delete update/;
418	return $proto;
419}
420
421sub find_or_create {
422	my $class    = shift;
423	my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
424	my ($exists) = $class->search($hash);
425	return defined($exists) ? $exists : $class->insert($hash);
426}
427
428sub insert {
429	my $class = shift;
430	return $class->_croak("insert needs a hashref") unless ref $_[0] eq 'HASH';
431	my $info = { %{ +shift } };    # make sure we take a copy
432
433	my $data;
434	while (my ($k, $v) = each %$info) {
435		my $col = $class->find_column($k)
436			|| (List::Util::first { $_->mutator  eq $k } $class->columns)
437			|| (List::Util::first { $_->accessor eq $k } $class->columns)
438			|| $class->_croak("$k is not a column of $class");
439		$data->{$col} = $v;
440	}
441
442	$class->normalize_column_values($data);
443	$class->validate_column_values($data);
444	return $class->_insert($data);
445}
446
447*create = \&insert;
448
449#----------------------------------------------------------------------
450# Low Level Data Access
451#----------------------------------------------------------------------
452
453sub _attrs {
454	my ($self, @atts) = @_;
455	return @{$self}{@atts};
456}
457*_attr = \&_attrs;
458
459sub _attribute_store {
460	my $self   = shift;
461	my $vals   = @_ == 1 ? shift: {@_};
462	my (@cols) = keys %$vals;
463	@{$self}{@cols} = @{$vals}{@cols};
464}
465
466# If you override this method, you must use the same mechanism to log changes
467# for future updates, as other parts of Class::DBI depend on it.
468sub _attribute_set {
469	my $self = shift;
470	my $vals = @_ == 1 ? shift: {@_};
471
472	# We increment instead of setting to 1 because it might be useful to
473	# someone to know how many times a value has changed between updates.
474	for my $col (keys %$vals) { $self->{__Changed}{$col}++; }
475	$self->_attribute_store($vals);
476}
477
478sub _attribute_delete {
479	my ($self, @attributes) = @_;
480	delete @{$self}{@attributes};
481}
482
483sub _attribute_exists {
484	my ($self, $attribute) = @_;
485	exists $self->{$attribute};
486}
487
488#----------------------------------------------------------------------
489# Live Object Index (using weak refs if available)
490#----------------------------------------------------------------------
491
492my %Live_Objects;
493my $Init_Count = 0;
494
495sub _init {
496	my $class = shift;
497	my $data  = shift || {};
498	my $key   = $class->_live_object_key($data);
499	return $Live_Objects{$key} || $class->_fresh_init($key => $data);
500}
501
502sub _fresh_init {
503	my ($class, $key, $data) = @_;
504	my $obj = bless {}, $class;
505	$obj->_attribute_store(%$data);
506
507	# don't store it unless all keys are present
508	if ($key && $Weaken_Is_Available) {
509		weaken($Live_Objects{$key} = $obj);
510
511		# time to clean up your room?
512		$class->purge_dead_from_object_index
513			if ++$Init_Count % $class->purge_object_index_every == 0;
514	}
515	return $obj;
516}
517
518sub _live_object_key {
519	my ($me, $data) = @_;
520	my $class   = ref($me) || $me;
521	my @primary = $class->primary_columns;
522
523	# no key unless all PK columns are defined
524	return "" unless @primary == grep defined $data->{$_}, @primary;
525
526	# create single unique key for this object
527	return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary;
528}
529
530sub purge_dead_from_object_index {
531	delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
532}
533
534sub remove_from_object_index {
535	my $self    = shift;
536	my $obj_key = $self->_live_object_key({ $self->_as_hash });
537	delete $Live_Objects{$obj_key};
538}
539
540sub clear_object_index {
541	%Live_Objects = ();
542}
543
544#----------------------------------------------------------------------
545
546sub _prepopulate_id {
547	my $self            = shift;
548	my @primary_columns = $self->primary_columns;
549	return $self->_croak(
550		sprintf "Can't create %s object with null primary key columns (%s)",
551		ref $self, $self->_undefined_primary)
552		if @primary_columns > 1;
553	$self->_attribute_store($primary_columns[0] => $self->_next_in_sequence)
554		if $self->sequence;
555}
556
557sub _insert {
558	my ($proto, $data) = @_;
559	my $class = ref $proto || $proto;
560
561	my $self = $class->_init($data);
562	$self->call_trigger('before_create');
563	$self->call_trigger('deflate_for_create');
564
565	$self->_prepopulate_id if $self->_undefined_primary;
566
567	# Reinstate data
568	my ($real, $temp) = ({}, {});
569	foreach my $col (grep $self->_attribute_exists($_), $self->all_columns) {
570		($class->has_real_column($col) ? $real : $temp)->{$col} =
571			$self->_attrs($col);
572	}
573	$self->_insert_row($real);
574
575	my @primary_columns = $class->primary_columns;
576	$self->_attribute_store(
577		$primary_columns[0] => $real->{ $primary_columns[0] })
578		if @primary_columns == 1;
579
580	delete $self->{__Changed};
581
582	my %primary_columns;
583	@primary_columns{@primary_columns} = ();
584	my @discard_columns = grep !exists $primary_columns{$_}, keys %$real;
585	$self->call_trigger('create', discard_columns => \@discard_columns);   # XXX
586
587	# Empty everything back out again!
588	$self->_attribute_delete(@discard_columns);
589	$self->call_trigger('after_create');
590	return $self;
591}
592
593sub _next_in_sequence {
594	my $self = shift;
595	return $self->sql_Nextval($self->sequence)->select_val;
596}
597
598sub _auto_increment_value {
599	my $self = shift;
600	my $dbh  = $self->db_Main;
601
602	# Try to do this in a standard method. Fall back to MySQL/SQLite
603	# specific versions. TODO remove these when last_insert_id is more
604	# widespread.
605	# Note: I don't believe the last_insert_id can be zero. We need to
606	# switch to defined() checks if it can.
607	my $id = $dbh->last_insert_id(undef, undef, $self->table, undef)    # std
608		|| $dbh->{mysql_insertid}                                         # mysql
609		|| eval { $dbh->func('last_insert_rowid') }
610		or $self->_croak("Can't get last insert id");
611	return $id;
612}
613
614sub _insert_row {
615	my $self = shift;
616	my $data = shift;
617	eval {
618		my @columns = keys %$data;
619		my $sth     = $self->sql_MakeNewObj(
620			join(', ', @columns),
621			join(', ', map $self->_column_placeholder($_), @columns),
622		);
623		$self->_bind_param($sth, \@columns);
624		$sth->execute(values %$data);
625		my @primary_columns = $self->primary_columns;
626		$data->{ $primary_columns[0] } = $self->_auto_increment_value
627			if @primary_columns == 1
628			&& !defined $data->{ $primary_columns[0] };
629	};
630	if ($@) {
631		my $class = ref $self;
632		return $self->_db_error(
633			msg    => "Can't insert new $class: $@",
634			err    => $@,
635			method => 'insert'
636		);
637	}
638	return 1;
639}
640
641sub _bind_param {
642	my ($class, $sth, $keys) = @_;
643	my $datatype = $class->__data_type or return;
644	for my $i (0 .. $#$keys) {
645		if (my $type = $datatype->{ $keys->[$i] }) {
646			$sth->bind_param($i + 1, undef, $type);
647		}
648	}
649}
650
651sub retrieve {
652	my $class           = shift;
653	my @primary_columns = $class->primary_columns
654		or return $class->_croak(
655		"Can't retrieve unless primary columns are defined");
656	my %key_value;
657	if (@_ == 1 && @primary_columns == 1) {
658		my $id = shift;
659		return unless defined $id;
660		return $class->_croak("Can't retrieve a reference") if ref($id);
661		$key_value{ $primary_columns[0] } = $id;
662	} else {
663		%key_value = @_;
664		$class->_croak(
665			"$class->retrieve(@_) parameters don't include values for all primary key columns (@primary_columns)"
666			)
667			if keys %key_value < @primary_columns;
668	}
669	my @rows = $class->search(%key_value);
670	$class->_carp("$class->retrieve(@_) selected " . @rows . " rows")
671		if @rows > 1;
672	return $rows[0];
673}
674
675# Get the data, as a hash, but setting certain values to whatever
676# we pass. Used by copy() and move().
677# This can take either a primary key, or a hashref of all the columns
678# to change.
679sub _data_hash {
680	my $self            = shift;
681	my %data            = $self->_as_hash;
682	my @primary_columns = $self->primary_columns;
683	delete @data{@primary_columns};
684	if (@_) {
685		my $arg = shift;
686		unless (ref $arg) {
687			$self->_croak("Need hash-ref to edit copied column values")
688				unless @primary_columns == 1;
689			$arg = { $primary_columns[0] => $arg };
690		}
691		@data{ keys %$arg } = values %$arg;
692	}
693	return \%data;
694}
695
696sub _as_hash {
697	my $self    = shift;
698	my @columns = $self->all_columns;
699	my %data;
700	@data{@columns} = $self->get(@columns);
701	return %data;
702}
703
704sub copy {
705	my $self = shift;
706	return $self->insert($self->_data_hash(@_));
707}
708
709#----------------------------------------------------------------------
710# CONSTRUCT
711#----------------------------------------------------------------------
712
713sub construct {
714	my ($proto, $data) = @_;
715	my $class = ref $proto || $proto;
716	my $self = $class->_init($data);
717	$self->call_trigger('select');
718	return $self;
719}
720
721sub move {
722	my ($class, $old_obj, @data) = @_;
723	$class->_carp("move() is deprecated. If you really need it, "
724			. "you should tell me quickly so I can abandon my plan to remove it.");
725	return $old_obj->_croak("Can't move to an unrelated class")
726		unless $class->isa(ref $old_obj)
727		or $old_obj->isa($class);
728	return $class->insert($old_obj->_data_hash(@data));
729}
730
731sub delete {
732	my $self = shift;
733	return $self->_search_delete(@_) if not ref $self;
734	$self->remove_from_object_index;
735	$self->call_trigger('before_delete');
736
737	eval { $self->sql_DeleteMe->execute($self->id) };
738	if ($@) {
739		return $self->_db_error(
740			msg    => "Can't delete $self: $@",
741			err    => $@,
742			method => 'delete'
743		);
744	}
745	$self->call_trigger('after_delete');
746	undef %$self;
747	bless $self, 'Class::DBI::Object::Has::Been::Deleted';
748	return 1;
749}
750
751sub _search_delete {
752	my ($class, @args) = @_;
753	$class->_carp(
754		"Delete as class method is deprecated. Use search and delete_all instead."
755	);
756	my $it = $class->search_like(@args);
757	while (my $obj = $it->next) { $obj->delete }
758	return 1;
759}
760
761# Return the placeholder to be used in UPDATE and INSERT queries.
762# Overriding this is deprecated in favour of
763#   __PACKAGE__->find_column('entered')->placeholder('IF(1, CURDATE(), ?));
764
765sub _column_placeholder {
766	my ($self, $column) = @_;
767	return $self->find_column($column)->placeholder;
768}
769
770sub update {
771	my $self  = shift;
772	my $class = ref($self)
773		or return $self->_croak("Can't call update as a class method");
774
775	$self->call_trigger('before_update');
776	return -1 unless my @changed_cols = $self->is_changed;
777	$self->call_trigger('deflate_for_update');
778	my @primary_columns = $self->primary_columns;
779	my $sth             = $self->sql_update($self->_update_line);
780	$class->_bind_param($sth, \@changed_cols);
781	my $rows = eval { $sth->execute($self->_update_vals, $self->id); };
782	if ($@) {
783		return $self->_db_error(
784			msg    => "Can't update $self: $@",
785			err    => $@,
786			method => 'update'
787		);
788	}
789
790	# enable this once new fixed DBD::SQLite is released:
791	if (0 and $rows != 1) {    # should always only update one row
792		$self->_croak("Can't update $self: row not found") if $rows == 0;
793		$self->_croak("Can't update $self: updated more than one row");
794	}
795
796	$self->call_trigger('after_update', discard_columns => \@changed_cols);
797
798	# delete columns that changed (in case adding to DB modifies them again)
799	$self->_attribute_delete(@changed_cols);
800	delete $self->{__Changed};
801	return 1;
802}
803
804sub _update_line {
805	my $self = shift;
806	join(', ', map "$_ = " . $self->_column_placeholder($_), $self->is_changed);
807}
808
809sub _update_vals {
810	my $self = shift;
811	$self->_attrs($self->is_changed);
812}
813
814sub DESTROY {
815	my ($self) = shift;
816	if (my @changed = $self->is_changed) {
817		my $class = ref $self;
818		$self->_carp("$class $self destroyed without saving changes to "
819				. join(', ', @changed));
820	}
821}
822
823sub discard_changes {
824	my $self = shift;
825	return $self->_croak("Can't discard_changes while autoupdate is on")
826		if $self->autoupdate;
827	$self->_attribute_delete($self->is_changed);
828	delete $self->{__Changed};
829	return 1;
830}
831
832# We override the get() method from Class::Accessor to fetch the data for
833# the column (and associated) columns from the database, using the _flesh()
834# method. We also allow get to be called with a list of keys, instead of
835# just one.
836
837sub get {
838	my $self = shift;
839	return $self->_croak("Can't fetch data as class method") unless ref $self;
840
841	my @cols = $self->_find_columns(@_);
842	return $self->_croak("Can't get() nothing!") unless @cols;
843
844	if (my @fetch_cols = grep !$self->_attribute_exists($_), @cols) {
845		$self->_flesh($self->__grouper->groups_for(@fetch_cols));
846	}
847
848	return $self->_attrs(@cols);
849}
850
851sub _flesh {
852	my ($self, @groups) = @_;
853	my @real = grep $_ ne "TEMP", @groups;
854	if (my @want = grep !$self->_attribute_exists($_),
855		$self->__grouper->columns_in(@real)) {
856		my %row;
857		@row{@want} = $self->sql_Flesh(join ", ", @want)->select_row($self->id);
858		$self->_attribute_store(\%row);
859		$self->call_trigger('select');
860	}
861	return 1;
862}
863
864# We also override set() from Class::Accessor so we can keep track of
865# changes, and either write to the database now (if autoupdate is on),
866# or when update() is called.
867sub set {
868	my $self          = shift;
869	my $column_values = {@_};
870
871	$self->normalize_column_values($column_values);
872	$self->validate_column_values($column_values);
873
874	while (my ($column, $value) = each %$column_values) {
875		my $col = $self->find_column($column) or die "No such column: $column\n";
876		$self->_attribute_set($col => $value);
877
878		# $self->SUPER::set($column, $value);
879
880		eval { $self->call_trigger("after_set_$column") };    # eg inflate
881		if ($@) {
882			$self->_attribute_delete($column);
883			return $self->_croak("after_set_$column trigger error: $@", err => $@);
884		}
885	}
886
887	$self->update if $self->autoupdate;
888	return 1;
889}
890
891sub is_changed {
892	my $self = shift;
893	grep $self->has_real_column($_), keys %{ $self->{__Changed} };
894}
895
896sub any_changed { keys %{ shift->{__Changed} } }
897
898# By default do nothing. Subclasses should override if required.
899#
900# Given a hash ref of column names and proposed new values,
901# edit the values in the hash if required.
902# For insert $self is the class name (not an object ref).
903sub normalize_column_values {
904	my ($self, $column_values) = @_;
905}
906
907# Given a hash ref of column names and proposed new values
908# validate that the whole set of new values in the hash
909# is valid for the object in relation to its current values
910# For insert $self is the class name (not an object ref).
911sub validate_column_values {
912	my ($self, $column_values) = @_;
913	my @errors;
914	foreach my $column (keys %$column_values) {
915		eval {
916			$self->call_trigger("before_set_$column", $column_values->{$column},
917				$column_values);
918		};
919		push @errors, $column => $@ if $@;
920	}
921	return unless @errors;
922	$self->_croak(
923		"validate_column_values error: " . join(" ", @errors),
924		method => 'validate_column_values',
925		data   => {@errors}
926	);
927}
928
929# We override set_sql() from Ima::DBI so it has a default database connection.
930sub set_sql {
931	my ($class, $name, $sql, $db, @others) = @_;
932	$db ||= 'Main';
933	$class->SUPER::set_sql($name, $sql, $db, @others);
934	$class->_generate_search_sql($name) if $sql =~ /select/i;
935	return 1;
936}
937
938sub _generate_search_sql {
939	my ($class, $name) = @_;
940	my $method = "search_$name";
941	defined &{"$class\::$method"}
942		and return $class->_carp("$method() already exists");
943	my $sql_method = "sql_$name";
944	no strict 'refs';
945	*{"$class\::$method"} = sub {
946		my ($class, @args) = @_;
947		return $class->sth_to_objects($name, \@args);
948	};
949}
950
951sub dbi_commit   { my $proto = shift; $proto->SUPER::commit(@_); }
952sub dbi_rollback { my $proto = shift; $proto->SUPER::rollback(@_); }
953
954#----------------------------------------------------------------------
955# Constraints / Triggers
956#----------------------------------------------------------------------
957
958sub constrain_column {
959	my $class = shift;
960	my $col   = $class->find_column(+shift)
961		or return $class->_croak("constraint_column needs a valid column");
962	my $how = shift
963		or return $class->_croak("constrain_column needs a constraint");
964	if (ref $how eq "ARRAY") {
965		my %hash = map { $_ => 1 } @$how;
966		$class->add_constraint(list => $col => sub { exists $hash{ +shift } });
967	} elsif (ref $how eq "Regexp") {
968		$class->add_constraint(regexp => $col => sub { shift =~ $how });
969	} elsif (ref $how eq "CODE") {
970		$class->add_constraint(
971			code => $col => sub { local $_ = $_[0]; $how->($_) });
972	} else {
973		my $try_method = sprintf '_constrain_by_%s', $how->moniker;
974		if (my $dispatch = $class->can($try_method)) {
975			$class->$dispatch($col => ($how, @_));
976		} else {
977			$class->_croak("Don't know how to constrain $col with $how");
978		}
979	}
980}
981
982sub add_constraint {
983	my $class = shift;
984	$class->_invalid_object_method('add_constraint()') if ref $class;
985	my $name = shift or return $class->_croak("Constraint needs a name");
986	my $column = $class->find_column(+shift)
987		or return $class->_croak("Constraint $name needs a valid column");
988	my $code = shift
989		or return $class->_croak("Constraint $name needs a code reference");
990	return $class->_croak("Constraint $name '$code' is not a code reference")
991		unless ref($code) eq "CODE";
992
993	$column->is_constrained(1);
994	$class->add_trigger(
995		"before_set_$column" => sub {
996			my ($self, $value, $column_values) = @_;
997			$code->($value, $self, $column, $column_values)
998				or return $self->_croak(
999				"$class $column fails '$name' constraint with '$value'",
1000				method         => "before_set_$column",
1001				exception_type => 'constraint_failure',
1002				data           => {
1003					column          => $column,
1004					value           => $value,
1005					constraint_name => $name,
1006				}
1007				);
1008		}
1009	);
1010}
1011
1012sub add_trigger {
1013	my ($self, $name, @args) = @_;
1014	return $self->_croak("on_setting trigger no longer exists")
1015		if $name eq "on_setting";
1016	$self->_carp(
1017		"$name trigger deprecated: use before_$name or after_$name instead")
1018		if ($name eq "create" or $name eq "delete");
1019	$self->SUPER::add_trigger($name => @args);
1020}
1021
1022#----------------------------------------------------------------------
1023# Inflation
1024#----------------------------------------------------------------------
1025
1026sub add_relationship_type {
1027	my ($self, %rels) = @_;
1028	while (my ($name, $class) = each %rels) {
1029		$self->_require_class($class);
1030		no strict 'refs';
1031		*{"$self\::$name"} = sub {
1032			my $proto = shift;
1033			$class->set_up($name => $proto => @_);
1034		};
1035	}
1036}
1037
1038sub _extend_meta {
1039	my ($class, $type, $subtype, $val) = @_;
1040	my %hash = %{ Clone::clone($class->__meta_info || {}) };
1041	$hash{$type}->{$subtype} = $val;
1042	$class->__meta_info(\%hash);
1043}
1044
1045sub meta_info {
1046	my ($class, $type, $subtype) = @_;
1047	my $meta = $class->__meta_info;
1048	return $meta          unless $type;
1049	return $meta->{$type} unless $subtype;
1050	return $meta->{$type}->{$subtype};
1051}
1052
1053sub _simple_bless {
1054	my ($class, $pri) = @_;
1055	return $class->_init({ $class->primary_column => $pri });
1056}
1057
1058sub _deflated_column {
1059	my ($self, $col, $val) = @_;
1060	$val ||= $self->_attrs($col) if ref $self;
1061	return $val unless ref $val;
1062	my $meta = $self->meta_info(has_a => $col) or return $val;
1063	my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args });
1064	if (my $deflate = $meths{'deflate'}) {
1065		$val = $val->$deflate(ref $deflate eq 'CODE' ? $self : ());
1066		return $val unless ref $val;
1067	}
1068	return $self->_croak("Can't deflate $col: $val is not a $a_class")
1069		unless UNIVERSAL::isa($val, $a_class);
1070	return $val->id if UNIVERSAL::isa($val => 'Class::DBI');
1071	return "$val";
1072}
1073
1074#----------------------------------------------------------------------
1075# SEARCH
1076#----------------------------------------------------------------------
1077
1078sub retrieve_all { shift->sth_to_objects('RetrieveAll') }
1079
1080sub retrieve_from_sql {
1081	my ($class, $sql, @vals) = @_;
1082	$sql =~ s/^\s*(WHERE)\s*//i;
1083	return $class->sth_to_objects($class->sql_Retrieve($sql), \@vals);
1084}
1085
1086sub add_searcher {
1087	my ($self, %rels) = @_;
1088	while (my ($name, $class) = each %rels) {
1089		$self->_require_class($class);
1090		$self->_croak("$class is not a valid Searcher")
1091			unless $class->can('run_search');
1092		no strict 'refs';
1093		*{"$self\::$name"} = sub {
1094			$class->new(@_)->run_search;
1095		};
1096	}
1097}
1098
1099# This should really be its own Search subclass. But the _do_search
1100# version has been publicised as the way to do this. We need to
1101# deprecate this eventually.
1102
1103sub search_like { shift->_do_search(LIKE => @_) }
1104
1105sub _do_search {
1106	my ($class, $type, @args) = @_;
1107	$class->_require_class('Class::DBI::Search::Basic');
1108	my $search = Class::DBI::Search::Basic->new($class, @args);
1109	$search->type($type);
1110	$search->run_search;
1111}
1112
1113#----------------------------------------------------------------------
1114# CONSTRUCTORS
1115#----------------------------------------------------------------------
1116
1117sub add_constructor {
1118	my ($class, $method, $fragment) = @_;
1119	return $class->_croak("constructors needs a name") unless $method;
1120	no strict 'refs';
1121	my $meth = "$class\::$method";
1122	return $class->_carp("$method already exists in $class")
1123		if *$meth{CODE};
1124	*$meth = sub {
1125		my $self = shift;
1126		$self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
1127	};
1128}
1129
1130sub sth_to_objects {
1131	my ($class, $sth, $args) = @_;
1132	$class->_croak("sth_to_objects needs a statement handle") unless $sth;
1133	unless (UNIVERSAL::isa($sth => "DBI::st")) {
1134		my $meth = "sql_$sth";
1135		$sth = $class->$meth();
1136	}
1137	my (%data, @rows);
1138	eval {
1139		$sth->execute(@$args) unless $sth->{Active};
1140		$sth->bind_columns(\(@data{ @{ $sth->{NAME_lc} } }));
1141		push @rows, {%data} while $sth->fetch;
1142	};
1143	return $class->_croak("$class can't $sth->{Statement}: $@", err => $@)
1144		if $@;
1145	return $class->_ids_to_objects(\@rows);
1146}
1147*_sth_to_objects = \&sth_to_objects;
1148
1149sub _my_iterator {
1150	my $self  = shift;
1151	my $class = $self->iterator_class;
1152	$self->_require_class($class);
1153	return $class;
1154}
1155
1156sub _ids_to_objects {
1157	my ($class, $data) = @_;
1158	return $#$data + 1 unless defined wantarray;
1159	return map $class->construct($_), @$data if wantarray;
1160	return $class->_my_iterator->new($class => $data);
1161}
1162
1163#----------------------------------------------------------------------
1164# SINGLE VALUE SELECTS
1165#----------------------------------------------------------------------
1166
1167sub _single_row_select {
1168	my ($self, $sth, @args) = @_;
1169	Carp::confess("_single_row_select is deprecated in favour of select_row");
1170	return $sth->select_row(@args);
1171}
1172
1173sub _single_value_select {
1174	my ($self, $sth, @args) = @_;
1175	$self->_carp("_single_value_select is deprecated in favour of select_val");
1176	return $sth->select_val(@args);
1177}
1178
1179sub count_all { shift->sql_single("COUNT(*)")->select_val }
1180
1181sub maximum_value_of {
1182	my ($class, $col) = @_;
1183	$class->sql_single("MAX($col)")->select_val;
1184}
1185
1186sub minimum_value_of {
1187	my ($class, $col) = @_;
1188	$class->sql_single("MIN($col)")->select_val;
1189}
1190
1191sub _unique_entries {
1192	my ($class, %tmp) = shift;
1193	return grep !$tmp{$_}++, @_;
1194}
1195
1196sub _invalid_object_method {
1197	my ($self, $method) = @_;
1198	$self->_carp(
1199		"$method should be called as a class method not an object method");
1200}
1201
1202#----------------------------------------------------------------------
1203# misc stuff
1204#----------------------------------------------------------------------
1205
1206sub _extend_class_data {
1207	my ($class, $struct, $key, $value) = @_;
1208	my %hash = %{ $class->$struct() || {} };
1209	$hash{$key} = $value;
1210	$class->$struct(\%hash);
1211}
1212
1213my %required_classes; # { required_class => class_that_last_required_it, ... }
1214
1215sub _require_class {
1216	my ($self, $load_class) = @_;
1217	$required_classes{$load_class} ||= my $for_class = ref($self) || $self;
1218
1219	# return quickly if class already exists
1220	no strict 'refs';
1221	return if exists ${"$load_class\::"}{ISA};
1222	(my $load_module = $load_class) =~ s!::!/!g;
1223	return if eval { require "$load_module.pm" };
1224
1225	# Only ignore "Can't locate" errors for the specific module we're loading
1226	return if $@ =~ /^Can't locate \Q$load_module\E\.pm /;
1227
1228	# Other fatal errors (syntax etc) must be reported (as per base.pm).
1229	chomp $@;
1230
1231	# This error message prefix is especially handy when dealing with
1232	# classes that are being loaded by other classes recursively.
1233	# The final message shows the path, e.g.:
1234	# Foo can't load Bar: Bar can't load Baz: syntax error at line ...
1235	$self->_croak("$for_class can't load $load_class: $@");
1236}
1237
1238sub _check_classes {    # may automatically call from CHECK block in future
1239	while (my ($load_class, $by_class) = each %required_classes) {
1240		next if $load_class->isa("Class::DBI");
1241		$by_class->_croak(
1242			"Class $load_class used by $by_class has not been loaded");
1243	}
1244}
1245
12461;
1247
1248__END__
1249
1250=head1 NAME
1251
1252Class::DBI - Simple Database Abstraction
1253
1254=head1 SYNOPSIS
1255
1256  package Music::DBI;
1257  use base 'Class::DBI';
1258  Music::DBI->connection('dbi:mysql:dbname', 'username', 'password');
1259
1260  package Music::Artist;
1261  use base 'Music::DBI';
1262  Music::Artist->table('artist');
1263  Music::Artist->columns(All => qw/artistid name/);
1264  Music::Artist->has_many(cds => 'Music::CD');
1265
1266  package Music::CD;
1267  use base 'Music::DBI';
1268  Music::CD->table('cd');
1269  Music::CD->columns(All => qw/cdid artist title year reldate/);
1270  Music::CD->has_many(tracks => 'Music::Track');
1271  Music::CD->has_a(artist => 'Music::Artist');
1272  Music::CD->has_a(reldate => 'Time::Piece',
1273    inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") },
1274    deflate => 'ymd',
1275  );
1276
1277  Music::CD->might_have(liner_notes => LinerNotes => qw/notes/);
1278
1279  package Music::Track;
1280  use base 'Music::DBI';
1281  Music::Track->table('track');
1282  Music::Track->columns(All => qw/trackid cd position title/);
1283
1284  #-- Meanwhile, in a nearby piece of code! --#
1285
1286  my $artist = Music::Artist->insert({ artistid => 1, name => 'U2' });
1287
1288  my $cd = $artist->add_to_cds({
1289    cdid   => 1,
1290    title  => 'October',
1291    year   => 1980,
1292  });
1293
1294  # Oops, got it wrong.
1295  $cd->year(1981);
1296  $cd->update;
1297
1298  # etc.
1299
1300  foreach my $track ($cd->tracks) {
1301    print $track->position, $track->title
1302  }
1303
1304  $cd->delete; # also deletes the tracks
1305
1306  my $cd  = Music::CD->retrieve(1);
1307  my @cds = Music::CD->retrieve_all;
1308  my @cds = Music::CD->search(year => 1980);
1309  my @cds = Music::CD->search_like(title => 'October%');
1310
1311=head1 INTRODUCTION
1312
1313Class::DBI provides a convenient abstraction layer to a database.
1314
1315It not only provides a simple database to object mapping layer, but can
1316be used to implement several higher order database functions (triggers,
1317referential integrity, cascading delete etc.), at the application level,
1318rather than at the database.
1319
1320This is particularly useful when using a database which doesn't support
1321these (such as MySQL), or when you would like your code to be portable
1322across multiple databases which might implement these things in different
1323ways.
1324
1325In short, Class::DBI aims to make it simple to introduce 'best
1326practice' when dealing with data stored in a relational database.
1327
1328=head2 How to set it up
1329
1330=over 4
1331
1332=item I<Set up a database.>
1333
1334You must have an existing database set up, have DBI.pm installed and
1335the necessary DBD:: driver module for that database.  See L<DBI> and
1336the documentation of your particular database and driver for details.
1337
1338=item I<Set up a table for your objects to be stored in.>
1339
1340Class::DBI works on a simple one class/one table model.  It is your
1341responsibility to have your database tables already set up. Automating that
1342process is outside the scope of Class::DBI.
1343
1344Using our CD example, you might declare a table something like this:
1345
1346  CREATE TABLE cd (
1347    cdid   INTEGER   PRIMARY KEY,
1348    artist INTEGER, # references 'artist'
1349    title  VARCHAR(255),
1350    year   CHAR(4),
1351  );
1352
1353=item I<Set up an application base class>
1354
1355It's usually wise to set up a "top level" class for your entire
1356application to inherit from, rather than have each class inherit
1357directly from Class::DBI.  This gives you a convenient point to
1358place system-wide overrides and enhancements to Class::DBI's behavior.
1359
1360  package Music::DBI;
1361  use base 'Class::DBI';
1362
1363=item I<Give it a database connection>
1364
1365Class::DBI needs to know how to access the database.  It does this
1366through a DBI connection which you set up by calling the connection()
1367method.
1368
1369  Music::DBI->connection('dbi:mysql:dbname', 'user', 'password');
1370
1371By setting the connection up in your application base class all the
1372table classes that inherit from it will share the same connection.
1373
1374=item I<Set up each Class>
1375
1376  package Music::CD;
1377  use base 'Music::DBI';
1378
1379Each class will inherit from your application base class, so you don't
1380need to repeat the information on how to connect to the database.
1381
1382=item I<Declare the name of your table>
1383
1384Inform Class::DBI what table you are using for this class:
1385
1386  Music::CD->table('cd');
1387
1388=item I<Declare your columns.>
1389
1390This is done using the columns() method. In the simplest form, you tell
1391it the name of all your columns (with the single primary key first):
1392
1393  Music::CD->columns(All => qw/cdid artist title year/);
1394
1395If the primary key of your table spans multiple columns then
1396declare them using a separate call to columns() like this:
1397
1398  Music::CD->columns(Primary => qw/pk1 pk2/);
1399  Music::CD->columns(Others => qw/foo bar baz/);
1400
1401For more information about how you can more efficiently use subsets of
1402your columns, see L</"LAZY POPULATION">
1403
1404=item I<Done.>
1405
1406That's it! You now have a class with methods to L<"insert">,
1407L<"retrieve">, L<"search"> for, L<"update"> and L<"delete"> objects
1408from your table, as well as accessors and mutators for each of the
1409columns in that object (row).
1410
1411=back
1412
1413Let's look at all that in more detail:
1414
1415=head1 CLASS METHODS
1416
1417=head2 connection
1418
1419  __PACKAGE__->connection($data_source, $user, $password, \%attr);
1420
1421This sets up a database connection with the given information.
1422
1423This uses L<Ima::DBI> to set up an inheritable connection (named Main). It is
1424therefore usual to only set up a connection() in your application base class
1425and let the 'table' classes inherit from it.
1426
1427  package Music::DBI;
1428  use base 'Class::DBI';
1429
1430  Music::DBI->connection('dbi:foo:dbname', 'user', 'password');
1431
1432  package My::Other::Table;
1433  use base 'Music::DBI';
1434
1435Class::DBI helps you along a bit to set up the database connection.
1436connection() provides its own default attributes depending on the driver
1437name in the data_source parameter. The connection() method provides defaults
1438for these attributes:
1439
1440  FetchHashKeyName   => 'NAME_lc',
1441  ShowErrorStatement => 1,
1442  ChopBlanks         => 1,
1443  AutoCommit         => 1,
1444
1445(Except for Oracle and Pg, where AutoCommit defaults 0, placing the
1446database in transactional mode).
1447
1448The defaults can always be extended (or overridden if you know what
1449you're doing) by supplying your own \%attr parameter. For example:
1450
1451  Music::DBI->connection(dbi:foo:dbname','user','pass',{ChopBlanks=>0});
1452
1453The RootClass of L<DBIx::ContextualFetch> in also inherited from L<Ima::DBI>,
1454and you should be very careful not to change this unless you know what
1455you're doing!
1456
1457=head3 Dynamic Database Connections / db_Main
1458
1459It is sometimes desirable to generate your database connection information
1460dynamically, for example, to allow multiple databases with the same
1461schema to not have to duplicate an entire class hierarchy.
1462
1463The preferred method for doing this is to supply your own db_Main()
1464method rather than calling L<"connection">. This method should return a
1465valid database handle, and should ensure it sets the standard attributes
1466described above, preferably by combining $class->_default_attributes()
1467with your own. Note, this handle *must* have its RootClass set to
1468L<DBIx::ContextualFetch>, so it is usually not possible to just supply a
1469$dbh obtained elsewhere.
1470
1471Note that connection information is class data, and that changing it
1472at run time may have unexpected behaviour for instances of the class
1473already in existence.
1474
1475=head2 table
1476
1477  __PACKAGE__->table($table);
1478
1479  $table = Class->table;
1480  $table = $obj->table;
1481
1482An accessor to get/set the name of the database table in which this
1483class is stored.  It -must- be set.
1484
1485Table information is inherited by subclasses, but can be overridden.
1486
1487=head2 table_alias
1488
1489  package Shop::Order;
1490  __PACKAGE__->table('orders');
1491  __PACKAGE__->table_alias('orders');
1492
1493When Class::DBI constructs SQL, it aliases your table name to a name
1494representing your class. However, if your class's name is an SQL reserved
1495word (such as 'Order') this will cause SQL errors. In such cases you
1496should supply your own alias for your table name (which can, of course,
1497be the same as the actual table name).
1498
1499This can also be passed as a second argument to 'table':
1500
1501  __PACKAGE__->table('orders', 'orders');
1502
1503As with table, this is inherited but can be overridden.
1504
1505=head2 sequence / auto_increment
1506
1507  __PACKAGE__->sequence($sequence_name);
1508
1509  $sequence_name = Class->sequence;
1510  $sequence_name = $obj->sequence;
1511
1512If you are using a database which supports sequences and you want to use
1513a sequence to automatically supply values for the primary key of a table,
1514then you should declare this using the sequence() method:
1515
1516  __PACKAGE__->columns(Primary => 'id');
1517  __PACKAGE__->sequence('class_id_seq');
1518
1519Class::DBI will use the sequence to generate a primary key value when
1520objects are inserted without one.
1521
1522*NOTE* This method does not work for Oracle. However, L<Class::DBI::Oracle>
1523(which can be downloaded separately from CPAN) provides a suitable
1524replacement sequence() method.
1525
1526If you are using a database with AUTO_INCREMENT (e.g. MySQL) then you do
1527not need this, and any call to insert() without a primary key specified
1528will fill this in automagically.
1529
1530Sequence and auto-increment mechanisms only apply to tables that have
1531a single column primary key. For tables with multi-column primary keys
1532you need to supply the key values manually.
1533
1534=head1 CONSTRUCTORS and DESTRUCTORS
1535
1536The following are methods provided for convenience to insert, retrieve
1537and delete stored objects.  It's not entirely one-size fits all and you
1538might find it necessary to override them.
1539
1540=head2 insert
1541
1542  my $obj = Class->insert(\%data);
1543
1544This is a constructor to insert new data into the database and create an
1545object representing the newly inserted row.
1546
1547%data consists of the initial information to place in your object and
1548the database.  The keys of %data match up with the columns of your
1549objects and the values are the initial settings of those fields.
1550
1551  my $cd = Music::CD->insert({
1552    cdid   => 1,
1553    artist => $artist,
1554    title  => 'October',
1555    year   => 1980,
1556  });
1557
1558If the table has a single primary key column and that column value
1559is not defined in %data, insert() will assume it is to be generated.
1560If a sequence() has been specified for this Class, it will use that.
1561Otherwise, it will assume the primary key can be generated by
1562AUTO_INCREMENT and attempt to use that.
1563
1564The C<before_create> trigger is invoked directly after storing the
1565supplied values into the new object and before inserting the record
1566into the database. The object stored in $self may not have all the
1567functionality of the final object after_creation, particularly if the
1568database is going to be providing the primary key value.
1569
1570For tables with multi-column primary keys you need to supply all
1571the key values, either in the arguments to the insert() method, or
1572by setting the values in a C<before_create> trigger.
1573
1574If the class has declared relationships with foreign classes via
1575has_a(), you can pass an object to insert() for the value of that key.
1576Class::DBI will Do The Right Thing.
1577
1578After the new record has been inserted into the database the data
1579for non-primary key columns is discarded from the object. If those
1580columns are accessed again they'll simply be fetched as needed.
1581This ensures that the data in the application is consistent with
1582what the database I<actually> stored.
1583
1584The C<after_create> trigger is invoked after the database insert
1585has executed.
1586
1587=head2 find_or_create
1588
1589  my $cd = Music::CD->find_or_create({ artist => 'U2', title => 'Boy' });
1590
1591This checks if a CD can be found to match the information passed, and
1592if not inserts it.
1593
1594=head2 delete
1595
1596  $obj->delete;
1597  Music::CD->search(year => 1980, title => 'Greatest %')->delete_all;
1598
1599Deletes this object from the database and from memory. If you have set up
1600any relationships using C<has_many> or C<might_have>, this will delete
1601the foreign elements also, recursively (cascading delete).  $obj is no
1602longer usable after this call.
1603
1604Multiple objects can be deleted by calling delete_all on the Iterator
1605returned from a search. Each object found will be deleted in turn,
1606so cascading delete and other triggers will be honoured.
1607
1608The C<before_delete> trigger is when an object instance is about to be
1609deleted. It is invoked before any cascaded deletes.  The C<after_delete>
1610trigger is invoked after the record has been deleted from the database
1611and just before the contents in memory are discarded.
1612
1613=head1 RETRIEVING OBJECTS
1614
1615Class::DBI provides a few very simple search methods.
1616
1617It is not the goal of Class::DBI to replace the need for using SQL. Users
1618are expected to write their own searches for more complex cases.
1619
1620L<Class::DBI::AbstractSearch>, available on CPAN, provides a much more
1621complex search interface than Class::DBI provides itself.
1622
1623=head2 retrieve
1624
1625  $obj = Class->retrieve( $id );
1626  $obj = Class->retrieve( %key_values );
1627
1628Given key values it will retrieve the object with that key from the
1629database.  For tables with a single column primary key a single
1630parameter can be used, otherwise a hash of key-name key-value pairs
1631must be given.
1632
1633  my $cd = Music::CD->retrieve(1) or die "No such cd";
1634
1635=head2 retrieve_all
1636
1637  my @objs = Class->retrieve_all;
1638  my $iterator = Class->retrieve_all;
1639
1640Retrieves objects for all rows in the database. This is probably a
1641bad idea if your table is big, unless you use the iterator version.
1642
1643=head2 search
1644
1645  @objs = Class->search(column1 => $value, column2 => $value ...);
1646
1647This is a simple search for all objects where the columns specified are
1648equal to the values specified e.g.:
1649
1650  @cds = Music::CD->search(year => 1990);
1651  @cds = Music::CD->search(title => "Greatest Hits", year => 1990);
1652
1653You may also specify the sort order of the results by adding a final
1654hash of arguments with the key 'order_by':
1655
1656  @cds = Music::CD->search(year => 1990, { order_by=>'artist' });
1657
1658This is passed through 'as is', enabling order_by clauses such
1659as 'year DESC, title'.
1660
1661=head2 search_like
1662
1663  @objs = Class->search_like(column1 => $like_pattern, ....);
1664
1665This is a simple search for all objects where the columns specified are
1666like the values specified.  $like_pattern is a pattern given in SQL LIKE
1667predicate syntax.  '%' means "any zero or more characters", '_' means
1668"any single character".
1669
1670  @cds = Music::CD->search_like(title => 'October%');
1671  @cds = Music::CD->search_like(title => 'Hits%', artist => 'Various%');
1672
1673You can also use 'order_by' with these, as with search().
1674
1675=head1 ITERATORS
1676
1677  my $it = Music::CD->search_like(title => 'October%');
1678  while (my $cd = $it->next) {
1679    print $cd->title;
1680  }
1681
1682Any of the above searches (as well as those defined by has_many) can also
1683be used as an iterator.  Rather than creating a list of objects matching
1684your criteria, this will return a Class::DBI::Iterator instance, which
1685can return the objects required one at a time.
1686
1687Currently the iterator initially fetches all the matching row data into
1688memory, and defers only the creation of the objects from that data until
1689the iterator is asked for the next object. So using an iterator will
1690only save significant memory if your objects will inflate substantially
1691when used.
1692
1693In the case of has_many relationships with a mapping method, the mapping
1694method is not called until each time you call 'next'. This means that
1695if your mapping is not a one-to-one, the results will probably not be
1696what you expect.
1697
1698=head2 Subclassing the Iterator
1699
1700  Music::CD->iterator_class('Music::CD::Iterator');
1701
1702You can also subclass the default iterator class to override its
1703functionality.  This is done via class data, and so is inherited into
1704your subclasses.
1705
1706=head2 QUICK RETRIEVAL
1707
1708  my $obj = Class->construct(\%data);
1709
1710This is used to turn data from the database into objects, and should
1711thus only be used when writing constructors. It is very handy for
1712cheaply setting up lots of objects from data for without going back to
1713the database.
1714
1715For example, instead of doing one SELECT to get a bunch of IDs and then
1716feeding those individually to retrieve() (and thus doing more SELECT
1717calls), you can do one SELECT to get the essential data of many objects
1718and feed that data to construct():
1719
1720   return map $class->construct($_), $sth->fetchall_hash;
1721
1722The construct() method creates a new empty object, loads in the column
1723values, and then invokes the C<select> trigger.
1724
1725=head1 COPY AND MOVE
1726
1727=head2 copy
1728
1729  $new_obj = $obj->copy;
1730  $new_obj = $obj->copy($new_id);
1731  $new_obj = $obj->copy({ title => 'new_title', rating => 18 });
1732
1733This creates a copy of the given $obj, removes the primary key,
1734sets any supplied column values and calls insert() to make a new
1735record in the database.
1736
1737For tables with a single column primary key, copy() can be called
1738with no parameters and the new object will be assigned a key
1739automatically.  Or a single parameter can be supplied and will be
1740used as the new key.
1741
1742For tables with a multi-column primary key, copy() must be called with
1743parameters which supply new values for all primary key columns, unless
1744a C<before_create> trigger will supply them. The insert() method will
1745fail if any primary key columns are not defined.
1746
1747  my $blrunner_dc = $blrunner->copy("Bladerunner: Director's Cut");
1748  my $blrunner_unrated = $blrunner->copy({
1749    Title => "Bladerunner: Director's Cut",
1750    Rating => 'Unrated',
1751  });
1752
1753=head2 move
1754
1755  my $new_obj = Sub::Class->move($old_obj);
1756  my $new_obj = Sub::Class->move($old_obj, $new_id);
1757  my $new_obj = Sub::Class->move($old_obj, \%changes);
1758
1759For transferring objects from one class to another. Similar to copy(), an
1760instance of Sub::Class is inserted using the data in $old_obj (Sub::Class
1761is a subclass of $old_obj's subclass). Like copy(), you can supply
1762$new_id as the primary key of $new_obj (otherwise the usual sequence or
1763autoincrement is used), or a hashref of multiple new values.
1764
1765=head1 TRIGGERS
1766
1767  __PACKAGE__->add_trigger(trigger_point_name => \&code_to_execute);
1768
1769  # e.g.
1770
1771  __PACKAGE__->add_trigger(after_create  => \&call_after_create);
1772
1773It is possible to set up triggers that will be called at various
1774points in the life of an object. Valid trigger points are:
1775
1776  before_create       (also used for deflation)
1777  after_create
1778  before_set_$column  (also used by add_constraint)
1779  after_set_$column   (also used for inflation and by has_a)
1780  before_update       (also used for deflation and by might_have)
1781  after_update
1782  before_delete
1783  after_delete
1784  select              (also used for inflation and by construct and _flesh)
1785
1786
1787You can create any number of triggers for each point, but you cannot
1788specify the order in which they will be run.
1789
1790All triggers are passed the object they are being fired for, except
1791when C<before_set_$column> is fired during L<"insert">, in which case
1792the class is passed in place of the object, which does not yet exist.
1793You may change object values if required.
1794
1795Some triggers are also passed extra parameters as name-value
1796pairs. The individual triggers are further documented with the methods
1797that trigger them.
1798
1799=head1 CONSTRAINTS
1800
1801  __PACKAGE__->add_constraint('name', column => \&check_sub);
1802
1803  # e.g.
1804
1805  __PACKAGE__->add_constraint('over18', age => \&check_age);
1806
1807  # Simple version
1808  sub check_age {
1809    my ($value) = @_;
1810    return $value >= 18;
1811  }
1812
1813  # Cross-field checking - must have SSN if age < 18
1814  sub check_age {
1815    my ($value, $self, $column_name, $changing) = @_;
1816    return 1 if $value >= 18;     # We're old enough.
1817    return 1 if $changing->{SSN}; # We're also being given an SSN
1818    return 0 if !ref($self);      # This is an insert, so we can't have an SSN
1819    return 1 if $self->ssn;       # We already have one in the database
1820    return 0;                     # We can't find an SSN anywhere
1821  }
1822
1823It is also possible to set up constraints on the values that can be set
1824on a column. The constraint on a column is triggered whenever an object
1825is created and whenever the value in that column is being changed.
1826
1827The constraint code is called with four parameters:
1828
1829  - The new value to be assigned
1830  - The object it will be assigned to
1831  (or class name when initially creating an object)
1832  - The name of the column
1833  (useful if many constraints share the same code)
1834  - A hash ref of all new column values being assigned
1835  (useful for cross-field validation)
1836
1837The constraints are applied to all the columns being set before the
1838object data is changed. Attempting to create or modify an object
1839where one or more constraint fail results in an exception and the object
1840remains unchanged.
1841
1842The exception thrown has its data set to a hashref of the column being
1843changed and the value being changed to.
1844
1845Note 1: Constraints are implemented using before_set_$column triggers.
1846This will only prevent you from setting these values through a
1847the provided insert() or set() methods. It will always be possible to
1848bypass this if you try hard enough.
1849
1850Note 2: When an object is created constraints are currently only
1851checked for column names included in the parameters to insert().
1852This is probably a bug and is likely to change in future.
1853
1854=head2 constrain_column
1855
1856  Film->constrain_column(year => qr/^\d{4}$/);
1857  Film->constrain_column(rating => [qw/U Uc PG 12 15 18/]);
1858  Film->constrain_column(title => sub { length() <= 20 });
1859
1860Simple anonymous constraints can also be added to a column using the
1861constrain_column() method.  By default this takes either a regex which
1862must match, a reference to a list of possible values, or a subref which
1863will have $_ aliased to the value being set, and should return a
1864true or false value.
1865
1866However, this behaviour can be extended (or replaced) by providing a
1867constraint handler for the type of argument passed to constrain_column.
1868This behavior should be provided in a method named "_constrain_by_$type",
1869where $type is the moniker of the argument. For example, the
1870year example above could be provided by _constrain_by_array().
1871
1872=head1 DATA NORMALIZATION
1873
1874Before an object is assigned data from the application (via insert or
1875a set accessor) the normalize_column_values() method is called with
1876a reference to a hash containing the column names and the new values
1877which are to be assigned (after any validation and constraint checking,
1878as described below).
1879
1880Currently Class::DBI does not offer any per-column mechanism here.
1881The default method is empty.  You can override it in your own classes
1882to normalize (edit) the data in any way you need. For example the values
1883in the hash for certain columns could be made lowercase.
1884
1885The method is called as an instance method when the values of an existing
1886object are being changed, and as a class method when a new object is
1887being created.
1888
1889=head1 DATA VALIDATION
1890
1891Before an object is assigned data from the application (via insert or
1892a set accessor) the validate_column_values() method is called with a
1893reference to a hash containing the column names and the new values which
1894are to be assigned.
1895
1896The method is called as an instance method when the values of an existing
1897object are being changed, and as a class method when a new object is
1898being inserted.
1899
1900The default method calls the before_set_$column trigger for each column
1901name in the hash. Each trigger is called inside an eval.  Any failures
1902result in an exception after all have been checked.  The exception data
1903is a reference to a hash which holds the column name and error text for
1904each trigger error.
1905
1906When using this mechanism for form data validation, for example,
1907this exception data can be stored in an exception object, via a
1908custom _croak() method, and then caught and used to redisplay the
1909form with error messages next to each field which failed validation.
1910
1911=head1 EXCEPTIONS
1912
1913All errors that are generated, or caught and propagated, by Class::DBI
1914are handled by calling the _croak() method (as an instance method
1915if possible, or else as a class method).
1916
1917The _croak() method is passed an error message and in some cases
1918some extra information as described below. The default behaviour
1919is simply to call Carp::croak($message).
1920
1921Applications that require custom behaviour should override the
1922_croak() method in their application base class (or table classes
1923for table-specific behaviour). For example:
1924
1925  use Error;
1926
1927  sub _croak {
1928    my ($self, $message, %info) = @_;
1929    # convert errors into exception objects
1930    # except for duplicate insert errors which we'll ignore
1931    Error->throw(-text => $message, %info)
1932      unless $message =~ /^Can't insert .* duplicate/;
1933    return;
1934  }
1935
1936The _croak() method is expected to trigger an exception and not
1937return. If it does return then it should use C<return;> so that an
1938undef or empty list is returned as required depending on the calling
1939context. You should only return other values if you are prepared to
1940deal with the (unsupported) consequences.
1941
1942For exceptions that are caught and propagated by Class::DBI, $message
1943includes the text of $@ and the original $@ value is available in $info{err}.
1944That allows you to correctly propagate exception objects that may have
1945been thrown 'below' Class::DBI (using L<Exception::Class::DBI> for example).
1946
1947Exceptions generated by some methods may provide additional data in
1948$info{data} and, if so, also store the method name in $info{method}.
1949For example, the validate_column_values() method stores details of
1950failed validations in $info{data}. See individual method documentation
1951for what additional data they may store, if any.
1952
1953=head1 WARNINGS
1954
1955All warnings are handled by calling the _carp() method (as
1956an instance method if possible, or else as a class method).
1957The default behaviour is simply to call Carp::carp().
1958
1959=head1 INSTANCE METHODS
1960
1961=head2 accessors
1962
1963Class::DBI inherits from L<Class::Accessor> and thus provides individual
1964accessor methods for every column in your subclass.  It also overrides
1965the get() and set() methods provided by Accessor to automagically handle
1966database reading and writing. (Note that as it doesn't make sense to
1967store a list of values in a column, set() takes a hash of column =>
1968value pairs, rather than the single key => values of Class::Accessor).
1969
1970=head2 the fundamental set() and get() methods
1971
1972  $value = $obj->get($column_name);
1973  @values = $obj->get(@column_names);
1974
1975  $obj->set($column_name => $value);
1976  $obj->set($col1 => $value1, $col2 => $value2 ... );
1977
1978These methods are the fundamental entry points for getting and setting
1979column values.  The extra accessor methods automatically generated for
1980each column of your table are simple wrappers that call these get()
1981and set() methods.
1982
1983The set() method calls normalize_column_values() then
1984validate_column_values() before storing the values.  The
1985C<before_set_$column> trigger is invoked by validate_column_values(),
1986checking any constraints that may have been set up.
1987
1988The C<after_set_$column> trigger is invoked after the new value has
1989been stored.
1990
1991It is possible for an object to not have all its column data in memory
1992(due to lazy inflation).  If the get() method is called for such a column
1993then it will select the corresponding group of columns and then invoke
1994the C<select> trigger.
1995
1996=head1 Changing Your Column Accessor Method Names
1997
1998=head2 accessor_name_for / mutator_name_for
1999
2000It is possible to change the name of the accessor method created for a
2001column either declaratively or programmatically.
2002
2003If, for example, you have a column with a name that clashes with a
2004method otherwise created by Class::DBI, such as 'meta_info', you could
2005create that Column explicitly with a different accessor (and/or
2006mutator) when setting up your columns:
2007
2008	my $meta_col = Class::DBI::Column->new(meta_info => {
2009		accessor => 'metadata',
2010	});
2011
2012  __PACKAGE__->columns(All => qw/id name/, $meta_col);
2013
2014If you want to change the name of all your accessors, or all that match
2015a certain pattern, you need to provide an accessor_name_for($col) method,
2016which will convert a column name to a method name.
2017
2018e.g: if your local database naming convention was to prepend the word
2019'customer' to each column in the 'customer' table, so that you had the
2020columns 'customerid', 'customername' and 'customerage', but you wanted
2021your methods to just be $customer->name and $customer->age rather than
2022$customer->customername etc., you could create a
2023
2024  sub accessor_name_for {
2025    my ($class, $column) = @_;
2026    $column =~ s/^customer//;
2027    return $column;
2028  }
2029
2030Similarly, if you wanted to have distinct accessor and mutator methods,
2031you could provide a mutator_name_for($col) method which would return
2032the name of the method to change the value:
2033
2034  sub mutator_name_for {
2035    my ($class, $column) = @_;
2036    return "set_" . $column->accessor;
2037  }
2038
2039If you override the mutator name, then the accessor method will be
2040enforced as read-only, and the mutator as write-only.
2041
2042=head2 update vs auto update
2043
2044There are two modes for the accessors to work in: manual update and
2045autoupdate. When in autoupdate mode, every time one calls an accessor
2046to make a change an UPDATE will immediately be sent to the database.
2047Otherwise, if autoupdate is off, no changes will be written until update()
2048is explicitly called.
2049
2050This is an example of manual updating:
2051
2052  # The calls to NumExplodingSheep() and Rating() will only make the
2053  # changes in memory, not in the database.  Once update() is called
2054  # it writes to the database in one swell foop.
2055  $gone->NumExplodingSheep(5);
2056  $gone->Rating('NC-17');
2057  $gone->update;
2058
2059And of autoupdating:
2060
2061  # Turn autoupdating on for this object.
2062  $gone->autoupdate(1);
2063
2064  # Each accessor call causes the new value to immediately be written.
2065  $gone->NumExplodingSheep(5);
2066  $gone->Rating('NC-17');
2067
2068Manual updating is probably more efficient than autoupdating and
2069it provides the extra safety of a discard_changes() option to clear out all
2070unsaved changes.  Autoupdating can be more convenient for the programmer.
2071Autoupdating is I<off> by default.
2072
2073If changes are neither updated nor rolled back when the object is
2074destroyed (falls out of scope or the program ends) then Class::DBI's
2075DESTROY method will print a warning about unsaved changes.
2076
2077=head2 autoupdate
2078
2079  __PACKAGE__->autoupdate($on_or_off);
2080  $update_style = Class->autoupdate;
2081
2082  $obj->autoupdate($on_or_off);
2083  $update_style = $obj->autoupdate;
2084
2085This is an accessor to the current style of auto-updating.  When called
2086with no arguments it returns the current auto-updating state, true for on,
2087false for off.  When given an argument it turns auto-updating on and off:
2088a true value turns it on, a false one off.
2089
2090When called as a class method it will control the updating style for
2091every instance of the class.  When called on an individual object it
2092will control updating for just that object, overriding the choice for
2093the class.
2094
2095  __PACKAGE__->autoupdate(1);     # Autoupdate is now on for the class.
2096
2097  $obj = Class->retrieve('Aliens Cut My Hair');
2098  $obj->autoupdate(0);      # Shut off autoupdating for this object.
2099
2100The update setting for an object is not stored in the database.
2101
2102=head2 update
2103
2104  $obj->update;
2105
2106If L<"autoupdate"> is not enabled then changes you make to your object are
2107not reflected in the database until you call update().  It is harmless
2108to call update() if there are no changes to be saved.  (If autoupdate
2109is on there'll never be anything to save.)
2110
2111Note: If you have transactions turned on for your database (but see
2112L<"TRANSACTIONS"> below) you will also need to call dbi_commit(), as
2113update() merely issues the UPDATE to the database).
2114
2115After the database update has been executed, the data for columns
2116that have been updated are deleted from the object. If those columns
2117are accessed again they'll simply be fetched as needed. This ensures
2118that the data in the application is consistent with what the database
2119I<actually> stored.
2120
2121When update() is called the C<before_update>($self) trigger is
2122always invoked immediately.
2123
2124If any columns have been updated then the C<after_update> trigger
2125is invoked after the database update has executed and is passed:
2126  ($self, discard_columns => \@discard_columns)
2127
2128The trigger code can modify the discard_columns array to affect
2129which columns are discarded.
2130
2131For example:
2132
2133  Class->add_trigger(after_update => sub {
2134    my ($self, %args) = @_;
2135    my $discard_columns = $args{discard_columns};
2136    # discard the md5_hash column if any field starting with 'foo'
2137    # has been updated - because the md5_hash will have been changed
2138    # by a trigger.
2139    push @$discard_columns, 'md5_hash' if grep { /^foo/ } @$discard_columns;
2140  });
2141
2142Take care to not delete a primary key column unless you know what
2143you're doing.
2144
2145The update() method returns the number of rows updated.  If the object
2146had not changed and thus did not need to issue an UPDATE statement,
2147the update() call will have a return value of -1.
2148
2149If the record in the database has been deleted, or its primary key value
2150changed, then the update will not affect any records and so the update()
2151method will return 0.
2152
2153=head2 discard_changes
2154
2155  $obj->discard_changes;
2156
2157Removes any changes you've made to this object since the last update.
2158Currently this simply discards the column values from the object.
2159
2160If you're using autoupdate this method will throw an exception.
2161
2162=head2 is_changed
2163
2164  my $changed = $obj->is_changed;
2165  my @changed_keys = $obj->is_changed;
2166
2167Indicates if the given $obj has changes since the last update. Returns
2168a list of keys which have changed. (If autoupdate is on, this method
2169will return an empty list, unless called inside a before_update or
2170after_set_$column trigger)
2171
2172=head2 id
2173
2174  $id = $obj->id;
2175  @id = $obj->id;
2176
2177Returns a unique identifier for this object based on the values in the
2178database. It's the equivalent of $obj->get($self->columns('Primary')),
2179with inflated values reduced to their ids.
2180
2181A warning will be generated if this method is used in scalar context on
2182a table with a multi-column primary key.
2183
2184=head2 LOW-LEVEL DATA ACCESS
2185
2186On some occasions, such as when you're writing triggers or constraint
2187routines, you'll want to manipulate data in a Class::DBI object without
2188using the usual get() and set() accessors, which may themselves call
2189triggers, fetch information from the database, etc.
2190
2191Rather than interacting directly with the data hash stored in a Class::DBI
2192object (the exact implementation of which may change in future releases)
2193you could use Class::DBI's low-level accessors. These appear 'private'
2194to make you think carefully about using them - they should not be a
2195common means of dealing with the object.
2196
2197The data within the object is modelled as a set of key-value pairs,
2198where the keys are normalized column names (returned by find_column()),
2199and the values are the data from the database row represented by the
2200object. Access is via these functions:
2201
2202=over 4
2203
2204=item _attrs
2205
2206  @values = $object->_attrs(@cols);
2207
2208Returns the values for one or more keys.
2209
2210=item _attribute_store
2211
2212  $object->_attribute_store( { $col0 => $val0, $col1 => $val1 } );
2213  $object->_attribute_store($col0, $val0, $col1, $val1);
2214
2215Stores values in the object.  They key-value pairs may be passed in
2216either as a simple list or as a hash reference.  This only updates
2217values in the object itself; changes will not be propagated to the
2218database.
2219
2220=item _attribute_set
2221
2222  $object->_attribute_set( { $col0 => $val0, $col1 => $val1 } );
2223  $object->_attribute_set($col0, $val0, $col1, $val1);
2224
2225Updates values in the object via _attribute_store(), but also logs
2226the changes so that they are propagated to the database with the next
2227update.  (Unlike set(), however, _attribute_set() will not trigger an
2228update if autoupdate is turned on.)
2229
2230=item _attribute_delete
2231
2232  @values = $object->_attribute_delete(@cols);
2233
2234Deletes values from the object, and returns the deleted values.
2235
2236=item _attribute_exists
2237
2238  $bool = $object->_attribute_exists($col);
2239
2240Returns a true value if the object contains a value for the specified
2241column, and a false value otherwise.
2242
2243=back
2244
2245By default, Class::DBI uses simple hash references to store object
2246data, but all access is via these routines, so if you want to
2247implement a different data model, just override these functions.
2248
2249=head2 OVERLOADED OPERATORS
2250
2251Class::DBI and its subclasses overload the perl builtin I<stringify>
2252and I<bool> operators. This is a significant convenience.
2253
2254The perl builtin I<bool> operator is overloaded so that a Class::DBI
2255object reference is true so long as all its key columns have defined
2256values.  (This means an object with an id() of zero is not considered
2257false.)
2258
2259When a Class::DBI object reference is used in a string context it will,
2260by default, return the value of the primary key. (Composite primary key
2261values will be separated by a slash).
2262
2263You can also specify the column(s) to be used for stringification via
2264the special 'Stringify' column group. So, for example, if you're using
2265an auto-incremented primary key, you could use this to provide a more
2266meaningful display string:
2267
2268  Widget->columns(Stringify => qw/name/);
2269
2270If you need to do anything more complex, you can provide an stringify_self()
2271method which stringification will call:
2272
2273  sub stringify_self {
2274    my $self = shift;
2275    return join ":", $self->id, $self->name;
2276  }
2277
2278This overloading behaviour can be useful for columns that have has_a()
2279relationships.  For example, consider a table that has price and currency
2280fields:
2281
2282  package Widget;
2283  use base 'My::Class::DBI';
2284  Widget->table('widget');
2285  Widget->columns(All => qw/widgetid name price currency_code/);
2286
2287  $obj = Widget->retrieve($id);
2288  print $obj->price . " " . $obj->currency_code;
2289
2290The would print something like "C<42.07 USD>".  If the currency_code
2291field is later changed to be a foreign key to a new currency table then
2292$obj->currency_code will return an object reference instead of a plain
2293string. Without overloading the stringify operator the example would now
2294print something like "C<42.07 Widget=HASH(0x1275}>" and the fix would
2295be to change the code to add a call to id():
2296
2297  print $obj->price . " " . $obj->currency_code->id;
2298
2299However, with overloaded stringification, the original code continues
2300to work as before, with no code changes needed.
2301
2302This makes it much simpler and safer to add relationships to existing
2303applications, or remove them later.
2304
2305=head1 TABLE RELATIONSHIPS
2306
2307Databases are all about relationships. Thus Class::DBI provides a way
2308for you to set up descriptions of your relationhips.
2309
2310Class::DBI provides three such relationships: 'has_a', 'has_many', and
2311'might_have'. Others are available from CPAN.
2312
2313=head2 has_a
2314
2315  Music::CD->has_a(column => 'Foreign::Class');
2316
2317  Music::CD->has_a(artist => 'Music::Artist');
2318  print $cd->artist->name;
2319
2320'has_a' is most commonly used to supply lookup information for a foreign
2321key. If a column is declared as storing the primary key of another
2322table, then calling the method for that column does not return the id,
2323but instead the relevant object from that foreign class.
2324
2325It is also possible to use has_a to inflate the column value to a non
2326Class::DBI based. A common usage would be to inflate a date field to a
2327date/time object:
2328
2329  Music::CD->has_a(reldate => 'Date::Simple');
2330  print $cd->reldate->format("%d %b, %Y");
2331
2332  Music::CD->has_a(reldate => 'Time::Piece',
2333    inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") },
2334    deflate => 'ymd',
2335  );
2336  print $cd->reldate->strftime("%d %b, %Y");
2337
2338If the foreign class is another Class::DBI representation retrieve is
2339called on that class with the column value. Any other object will be
2340instantiated either by calling new($value) or using the given 'inflate'
2341method. If the inflate method name is a subref, it will be executed,
2342and will be passed the value and the Class::DBI object as arguments.
2343
2344When the object is being written to the database the object will be
2345deflated either by calling the 'deflate' method (if given), or by
2346attempting to stringify the object. If the deflate method is a subref,
2347it will be passed the Class::DBI object as an argument.
2348
2349*NOTE* You should not attempt to make your primary key column inflate
2350using has_a() as bad things will happen. If you have two tables which
2351share a primary key, consider using might_have() instead.
2352
2353=head2 has_many
2354
2355  Class->has_many(method_to_create => "Foreign::Class");
2356
2357  Music::CD->has_many(tracks => 'Music::Track');
2358
2359  my @tracks = $cd->tracks;
2360
2361  my $track6 = $cd->add_to_tracks({
2362    position => 6,
2363    title    => 'Tomorrow',
2364  });
2365
2366This method declares that another table is referencing us (i.e. storing
2367our primary key in its table).
2368
2369It creates a named accessor method in our class which returns a list of
2370all the matching Foreign::Class objects.
2371
2372In addition it creates another method which allows a new associated object
2373to be constructed, taking care of the linking automatically. This method
2374is the same as the accessor method with "add_to_" prepended.
2375
2376The add_to_tracks example above is exactly equivalent to:
2377
2378  my $track6 = Music::Track->insert({
2379    cd       => $cd,
2380    position => 6,
2381    title    => 'Tomorrow',
2382  });
2383
2384When setting up the relationship the foreign class's has_a() declarations
2385are examined to discover which of its columns reference our class. (Note
2386that because this happens at compile time, if the foreign class is defined
2387in the same file, the class with the has_a() must be defined earlier than
2388the class with the has_many(). If the classes are in different files,
2389Class::DBI should usually be able to do the right things, as long as all
2390classes inherit Class::DBI before 'use'ing any other classes.)
2391
2392If the foreign class has no has_a() declarations linking to this class,
2393it is assumed that the foreign key in that class is named after the
2394moniker() of this class.
2395
2396If this is not true you can pass an additional third argument to
2397the has_many() declaration stating which column of the foreign class
2398is the foreign key to this class.
2399
2400=head3 Limiting
2401
2402  Music::Artist->has_many(cds => 'Music::CD');
2403  my @cds = $artist->cds(year => 1980);
2404
2405When calling the method created by has_many, you can also supply any
2406additional key/value pairs for restricting the search. The above example
2407will only return the CDs with a year of 1980.
2408
2409=head3 Ordering
2410
2411  Music::CD->has_many(tracks => 'Music::Track', { order_by => 'playorder' });
2412
2413has_many takes an optional final hashref of options. If an 'order_by'
2414option is set, its value will be set in an ORDER BY clause in the SQL
2415issued. This is passed through 'as is', enabling order_by clauses such
2416as 'length DESC, position'.
2417
2418=head3 Mapping
2419
2420  Music::CD->has_many(styles => [ 'Music::StyleRef' => 'style' ]);
2421
2422If the second argument to has_many is turned into a listref of the
2423Classname and an additional method, then that method will be called in
2424turn on each of the objects being returned.
2425
2426The above is exactly equivalent to:
2427
2428  Music::CD->has_many(_style_refs => 'Music::StyleRef');
2429
2430  sub styles {
2431    my $self = shift;
2432    return map $_->style, $self->_style_refs;
2433  }
2434
2435For an example of where this is useful see L<"MANY TO MANY RELATIONSHIPS">
2436below.
2437
2438=head3 Cascading Delete
2439
2440  Music::Artist->has_many(cds => 'Music::CD', { cascade => 'Fail' });
2441
2442It is also possible to control what happens to the 'child' objects when
2443the 'parent' object is deleted. By default this is set to 'Delete' - so,
2444for example, when you delete an artist, you also delete all their CDs,
2445leaving no orphaned records. However you could also set this to 'None',
2446which would leave all those orphaned records (although this generally
2447isn't a good idea), or 'Fail', which will throw an exception when you
2448try to delete an artist that still has any CDs.
2449
2450You can also write your own Cascade strategies by supplying a Class
2451Name here.
2452
2453For example you could write a Class::DBI::Cascade::Plugin::Nullify
2454which would set all related foreign keys to be NULL, and plug it into
2455your relationship:
2456
2457  Music::Artist->has_many(cds => 'Music::CD', {
2458    cascade => 'Class::DBI::Cascade::Plugin::Nullify'
2459  });
2460
2461=head2 might_have
2462
2463  Music::CD->might_have(method_name => Class => (@fields_to_import));
2464
2465  Music::CD->might_have(liner_notes => LinerNotes => qw/notes/);
2466
2467  my $liner_notes_object = $cd->liner_notes;
2468  my $notes = $cd->notes; # equivalent to $cd->liner_notes->notes;
2469
2470might_have() is similar to has_many() for relationships that can have
2471at most one associated objects. For example, if you have a CD database
2472to which you want to add liner notes information, you might not want
2473to add a 'liner_notes' column to your main CD table even though there
2474is no multiplicity of relationship involved (each CD has at most one
2475'liner notes' field). So, you create another table with the same primary
2476key as this one, with which you can cross-reference.
2477
2478But you don't want to have to keep writing methods to turn the the
2479'list' of liner_notes objects you'd get back from has_many into the
2480single object you'd need. So, might_have() does this work for you. It
2481creates an accessor to fetch the single object back if it exists, and
2482it also allows you import any of its methods into your namespace. So,
2483in the example above, the LinerNotes class can be mostly invisible -
2484you can just call $cd->notes and it will call the notes method on the
2485correct LinerNotes object transparently for you.
2486
2487Making sure you don't have namespace clashes is up to you, as is correctly
2488creating the objects, but this may be made simpler in later versions.
2489(Particularly if someone asks for this!)
2490
2491=head2 Notes
2492
2493has_a(), might_have() and has_many() check that the relevant class has
2494already been loaded. If it hasn't then they try to load the module of
2495the same name using require.  If the require fails because it can't
2496find the module then it will assume it's not a simple require (i.e.,
2497Foreign::Class isn't in Foreign/Class.pm) and that you will take care
2498of it and ignore the warning. Any other error, such as a syntax error,
2499triggers an exception.
2500
2501NOTE: The two classes in a relationship do not have to be in the same
2502database, on the same machine, or even in the same type of database! It
2503is quite acceptable for a table in a MySQL database to be connected to
2504a different table in an Oracle database, and for cascading delete etc
2505to work across these. This should assist greatly if you need to migrate
2506a database gradually.
2507
2508=head1 MANY TO MANY RELATIONSHIPS
2509
2510Class::DBI does not currently support Many to Many relationships, per se.
2511However, by combining the relationships that already exist it is possible
2512to set these up.
2513
2514Consider the case of Films and Actors, with a linking Role table with a
2515multi-column Primary Key. First of all set up the Role class:
2516
2517  Role->table('role');
2518  Role->columns(Primary => qw/film actor/);
2519  Role->has_a(film => 'Film');
2520  Role->has_a(actor => 'Actor');
2521
2522Then, set up the Film and Actor classes to use this linking table:
2523
2524  Film->table('film');
2525  Film->columns(All => qw/id title rating/);
2526  Film->has_many(stars => [ Role => 'actor' ]);
2527
2528  Actor->table('actor');
2529  Actor->columns(All => qw/id name/);
2530  Actor->has_many(films => [ Role => 'film' ]);
2531
2532In each case the 'mapping method' variation of has_many() is used to
2533call the lookup method on the Role object returned. As these methods are
2534the 'has_a' relationships on the Role, these will return the actual
2535Actor and Film objects, providing a cheap many-to-many relationship.
2536
2537In the case of Film, this is equivalent to the more long-winded:
2538
2539  Film->has_many(roles => "Role");
2540
2541  sub actors {
2542    my $self = shift;
2543    return map $_->actor, $self->roles
2544  }
2545
2546As this is almost exactly what is created internally, add_to_stars and
2547add_to_films will generally do the right thing as they are actually
2548doing the equivalent of add_to_roles:
2549
2550  $film->add_to_actors({ actor => $actor });
2551
2552Similarly a cascading delete will also do the right thing as it will
2553only delete the relationship from the linking table.
2554
2555If the Role table were to contain extra information, such as the name
2556of the character played, then you would usually need to skip these
2557short-cuts and set up each of the relationships, and associated helper
2558methods, manually.
2559
2560=head1 ADDING NEW RELATIONSHIP TYPES
2561
2562=head2 add_relationship_type
2563
2564The relationships described above are implemented through
2565Class::DBI::Relationship subclasses.  These are then plugged into
2566Class::DBI through an add_relationship_type() call:
2567
2568  __PACKAGE__->add_relationship_type(
2569    has_a      => "Class::DBI::Relationship::HasA",
2570    has_many   => "Class::DBI::Relationship::HasMany",
2571    might_have => "Class::DBI::Relationship::MightHave",
2572  );
2573
2574If is thus possible to add new relationship types, or modify the behaviour
2575of the existing types.  See L<Class::DBI::Relationship> for more information
2576on what is required.
2577
2578=head1 DEFINING SQL STATEMENTS
2579
2580There are several main approaches to setting up your own SQL queries:
2581
2582For queries which could be used to create a list of matching objects
2583you can create a constructor method associated with this SQL and let
2584Class::DBI do the work for you, or just inline the entire query.
2585
2586For more complex queries you need to fall back on the underlying Ima::DBI
2587query mechanism. (Caveat: since Ima::DBI uses sprintf-style interpolation,
2588you need to be careful to double any "wildcard" % signs in your queries).
2589
2590=head2 add_constructor
2591
2592  __PACKAGE__->add_constructor(method_name => 'SQL_where_clause');
2593
2594The SQL can be of arbitrary complexity and will be turned into:
2595
2596  SELECT (essential columns)
2597    FROM (table name)
2598   WHERE <your SQL>
2599
2600This will then create a method of the name you specify, which returns
2601a list of objects as with any built in query.
2602
2603For example:
2604
2605  Music::CD->add_constructor(new_music => 'year > 2000');
2606  my @recent = Music::CD->new_music;
2607
2608You can also supply placeholders in your SQL, which must then be
2609specified at query time:
2610
2611  Music::CD->add_constructor(new_music => 'year > ?');
2612  my @recent = Music::CD->new_music(2000);
2613
2614=head2 retrieve_from_sql
2615
2616On occasions where you want to execute arbitrary SQL, but don't want
2617to go to the trouble of setting up a constructor method, you can inline
2618the entire WHERE clause, and just get the objects back directly:
2619
2620  my @cds = Music::CD->retrieve_from_sql(qq{
2621    artist = 'Ozzy Osbourne' AND
2622    title like "%Crazy"      AND
2623    year <= 1986
2624    ORDER BY year
2625    LIMIT 2,3
2626  });
2627
2628=head2 Ima::DBI queries
2629
2630When you can't use 'add_constructor', e.g. when using aggregate functions,
2631you can fall back on the fact that Class::DBI inherits from Ima::DBI
2632and prefers to use its style of dealing with statements, via set_sql().
2633
2634The Class::DBI set_sql() method defaults to using prepare_cached()
2635unless the $cache parameter is defined and false (see L<Ima::DBI> docs for
2636more information).
2637
2638To assist with writing SQL that is inheritable into subclasses, several
2639additional substitutions are available here: __TABLE__, __ESSENTIAL__
2640and __IDENTIFIER__.  These represent the table name associated with the
2641class, its essential columns, and the primary key of the current object,
2642in the case of an instance method on it.
2643
2644For example, the SQL for the internal 'update' method is implemented as:
2645
2646  __PACKAGE__->set_sql('update', <<"");
2647    UPDATE __TABLE__
2648    SET    %s
2649    WHERE  __IDENTIFIER__
2650
2651The 'longhand' version of the new_music constructor shown above would
2652similarly be:
2653
2654  Music::CD->set_sql(new_music => qq{
2655    SELECT __ESSENTIAL__
2656      FROM __TABLE__
2657     WHERE year > ?
2658  });
2659
2660For such 'SELECT' queries L<Ima::DBI>'s set_sql() method is extended to
2661create a helper shortcut method, named by prefixing the name of the
2662SQL fragment with 'search_'. Thus, the above call to set_sql() will
2663automatically set up the method Music::CD->search_new_music(), which
2664will execute this search and return the relevant objects or Iterator.
2665(If there are placeholders in the query, you must pass the relevant
2666arguments when calling your search method.)
2667
2668This does the equivalent of:
2669
2670  sub search_new_music {
2671    my ($class, @args) = @_;
2672    my $sth = $class->sql_new_music;
2673    $sth->execute(@args);
2674    return $class->sth_to_objects($sth);
2675  }
2676
2677The $sth which is used to return the objects here is a normal DBI-style
2678statement handle, so if the results can't be turned into objects easily,
2679it is still possible to call $sth->fetchrow_array etc and return whatever
2680data you choose.
2681
2682Of course, any query can be added via set_sql, including joins.  So,
2683to add a query that returns the 10 Artists with the most CDs, you could
2684write (with MySQL):
2685
2686  Music::Artist->set_sql(most_cds => qq{
2687    SELECT artist.id, COUNT(cd.id) AS cds
2688      FROM artist, cd
2689     WHERE artist.id = cd.artist
2690     GROUP BY artist.id
2691     ORDER BY cds DESC
2692     LIMIT 10
2693  });
2694
2695  my @artists = Music::Artist->search_most_cds();
2696
2697If you also need to access the 'cds' value returned from this query,
2698the best approach is to declare 'cds' to be a TEMP column. (See
2699L<"Non-Persistent Fields"> below).
2700
2701=head2 Class::DBI::AbstractSearch
2702
2703  my @music = Music::CD->search_where(
2704    artist => [ 'Ozzy', 'Kelly' ],
2705    status => { '!=', 'outdated' },
2706  );
2707
2708The L<Class::DBI::AbstractSearch> module, available from CPAN, is a
2709plugin for Class::DBI that allows you to write arbitrarily complex
2710searches using perl data structures, rather than SQL.
2711
2712=head2 Single Value SELECTs
2713
2714=head3 select_val
2715
2716Selects which only return a single value can couple Class::DBI's
2717sql_single() SQL, with the $sth->select_val() call which we get from
2718DBIx::ContextualFetch.
2719
2720  __PACKAGE__->set_sql(count_all => "SELECT COUNT(*) FROM __TABLE__");
2721  # .. then ..
2722  my $count = $class->sql_count_all->select_val;
2723
2724This can also take placeholders and/or do column interpolation if required:
2725
2726  __PACKAGE__->set_sql(count_above => q{
2727    SELECT COUNT(*) FROM __TABLE__ WHERE %s > ?
2728  });
2729  # .. then ..
2730  my $count = $class->sql_count_above('year')->select_val(2001);
2731
2732=head3 sql_single
2733
2734Internally Class::DBI defines a very simple SQL fragment called 'single':
2735
2736  "SELECT %s FROM __TABLE__".
2737
2738This is used to implement the above Class->count_all():
2739
2740  $class->sql_single("COUNT(*)")->select_val;
2741
2742This interpolates the COUNT(*) into the %s of the SQL, and then executes
2743the query, returning a single value.
2744
2745Any SQL set up via set_sql() can of course be supplied here, and
2746select_val can take arguments for any placeholders there.
2747
2748Internally several helper methods are defined using this approach:
2749
2750=over 4
2751
2752=item - count_all
2753
2754=item - maximum_value_of($column)
2755
2756=item - minimum_value_of($column)
2757
2758=back
2759
2760=head1 LAZY POPULATION
2761
2762In the tradition of Perl, Class::DBI is lazy about how it loads your
2763objects.  Often, you find yourself using only a small number of the
2764available columns and it would be a waste of memory to load all of them
2765just to get at two, especially if you're dealing with large numbers of
2766objects simultaneously.
2767
2768You should therefore group together your columns by typical usage, as
2769fetching one value from a group can also pre-fetch all the others in
2770that group for you, for more efficient access.
2771
2772So for example, if we usually fetch the artist and title, but don't use
2773the 'year' so much, then we could say the following:
2774
2775  Music::CD->columns(Primary   => qw/cdid/);
2776  Music::CD->columns(Essential => qw/artist title/);
2777  Music::CD->columns(Others    => qw/year runlength/);
2778
2779Now when you fetch back a CD it will come pre-loaded with the 'cdid',
2780'artist' and 'title' fields. Fetching the 'year' will mean another visit
2781to the database, but will bring back the 'runlength' whilst it's there.
2782
2783This can potentially increase performance.
2784
2785If you don't like this behavior, then just add all your columns to the
2786Essential group, and Class::DBI will load everything at once. If you
2787have a single column primary key you can do this all in one shot with
2788one single column declaration:
2789
2790  Music::CD->columns(Essential => qw/cdid artist title year runlength/);
2791
2792=head2 columns
2793
2794  my @all_columns  = $class->columns;
2795  my @columns      = $class->columns($group);
2796
2797  my @primary      = $class->primary_columns;
2798  my $primary      = $class->primary_column;
2799  my @essential    = $class->_essential;
2800
2801There are four 'reserved' groups: 'All', 'Essential', 'Primary' and
2802'TEMP'.
2803
2804B<'All'> are all columns used by the class. If not set it will be
2805created from all the other groups.
2806
2807B<'Primary'> is the primary key columns for this class. It I<must>
2808be set before objects can be used.
2809
2810If 'All' is given but not 'Primary' it will assume the first column in
2811'All' is the primary key.
2812
2813B<'Essential'> are the minimal set of columns needed to load and use the
2814object. Only the columns in this group will be loaded when an object
2815is retrieve()'d. It is typically used to save memory on a class that
2816has a lot of columns but where only use a few of them are commonly
2817used. It will automatically be set to B<'Primary'> if not explicitly set.
2818The 'Primary' column is always part of the 'Essential' group.
2819
2820For simplicity primary_columns(), primary_column(), and _essential()
2821methods are provided to return these. The primary_column() method should
2822only be used for tables that have a single primary key column.
2823
2824=head2 Non-Persistent Fields
2825
2826  Music::CD->columns(TEMP => qw/nonpersistent/);
2827
2828If you wish to have fields that act like columns in every other way, but
2829that don't actually exist in the database (and thus will not persist),
2830you can declare them as part of a column group of 'TEMP'.
2831
2832=head2 find_column
2833
2834  Class->find_column($column);
2835  $obj->find_column($column);
2836
2837The columns of a class are stored as Class::DBI::Column objects. This
2838method will return you the object for the given column, if it exists.
2839This is most useful either in a boolean context to discover if the column
2840exists, or to 'normalize' a user-entered column name to an actual Column.
2841
2842The interface of the Column object itself is still under development,
2843so you shouldn't really rely on anything internal to it.
2844
2845=head1 TRANSACTIONS
2846
2847Class::DBI suffers from the usual problems when dealing with transactions.
2848In particular, you should be very wary when committing your changes that
2849you may actually be in a wider scope than expected and that your caller
2850may not be expecting you to commit.
2851
2852However, as long as you are aware of this, and try to keep the scope
2853of your transactions small, ideally always within the scope of a single
2854method, you should be able to work with transactions with few problems.
2855
2856=head2 dbi_commit / dbi_rollback
2857
2858  $obj->dbi_commit();
2859  $obj->dbi_rollback();
2860
2861These are thin aliases through to the DBI's commit() and rollback()
2862commands to commit or rollback all changes to this object.
2863
2864=head2 Localised Transactions
2865
2866A nice idiom for turning on a transaction locally (with AutoCommit turned
2867on globally) (courtesy of Dominic Mitchell) is:
2868
2869  sub do_transaction {
2870    my $class = shift;
2871    my ( $code ) = @_;
2872    # Turn off AutoCommit for this scope.
2873    # A commit will occur at the exit of this block automatically,
2874    # when the local AutoCommit goes out of scope.
2875    local $class->db_Main->{ AutoCommit };
2876
2877    # Execute the required code inside the transaction.
2878    eval { $code->() };
2879    if ( $@ ) {
2880      my $commit_error = $@;
2881      eval { $class->dbi_rollback }; # might also die!
2882      die $commit_error;
2883    }
2884  }
2885
2886  And then you just call:
2887
2888  Music::DBI->do_transaction( sub {
2889    my $artist = Music::Artist->insert({ name => 'Pink Floyd' });
2890    my $cd = $artist->add_to_cds({
2891      title => 'Dark Side Of The Moon',
2892      year => 1974,
2893    });
2894  });
2895
2896Now either both will get added, or the entire transaction will be
2897rolled back.
2898
2899=head1 UNIQUENESS OF OBJECTS IN MEMORY
2900
2901Class::DBI supports uniqueness of objects in memory. In a given perl
2902interpreter there will only be one instance of any given object at
2903one time. Many variables may reference that object, but there can be
2904only one.
2905
2906Here's an example to illustrate:
2907
2908  my $artist1 = Music::Artist->insert({ artistid => 7, name => 'Polysics' });
2909  my $artist2 = Music::Artist->retrieve(7);
2910  my $artist3 = Music::Artist->search( name => 'Polysics' )->first;
2911
2912Now $artist1, $artist2, and $artist3 all point to the same object. If you
2913update a property on one of them, all of them will reflect the update.
2914
2915This is implemented using a simple object lookup index for all live
2916objects in memory. It is not a traditional cache - when your objects
2917go out of scope, they will be destroyed normally, and a future retrieve
2918will instantiate an entirely new object.
2919
2920The ability to perform this magic for you replies on your perl having
2921access to the Scalar::Util::weaken function. Although this is part of
2922the core perl distribution, some vendors do not compile support for it.
2923To find out if your perl has support for it, you can run this on the
2924command line:
2925
2926  perl -e 'use Scalar::Util qw(weaken)'
2927
2928If you get an error message about weak references not being implemented,
2929Class::DBI will not maintain this lookup index, but give you a separate
2930instances for each retrieve.
2931
2932A few new tools are offered for adjusting the behavior of the object
2933index. These are still somewhat experimental and may change in a
2934future release.
2935
2936=head2 remove_from_object_index
2937
2938  $artist->remove_from_object_index();
2939
2940This is an object method for removing a single object from the live
2941objects index. You can use this if you want to have multiple distinct
2942copies of the same object in memory.
2943
2944=head2 clear_object_index
2945
2946  Music::DBI->clear_object_index();
2947
2948You can call this method on any class or instance of Class::DBI, but
2949the effect is universal: it removes all objects from the index.
2950
2951=head2 purge_object_index_every
2952
2953  Music::Artist->purge_object_index_every(2000);
2954
2955Weak references are not removed from the index when an object goes
2956out of scope. This means that over time the index will grow in memory.
2957This is really only an issue for long-running environments like mod_perl,
2958but every so often dead references are cleaned out to prevent this. By
2959default, this happens every 1000 object loads, but you can change that
2960default for your class by setting the 'purge_object_index_every' value.
2961
2962(Eventually this may handled in the DESTROY method instead.)
2963
2964As a final note, keep in mind that you can still have multiple distinct
2965copies of an object in memory if you have multiple perl interpreters
2966running. CGI, mod_perl, and many other common usage situations run
2967multiple interpreters, meaning that each one of them may have an instance
2968of an object representing the same data. However, this is no worse
2969than it was before, and is entirely normal for database applications in
2970multi-process environments.
2971
2972=head1 SUBCLASSING
2973
2974The preferred method of interacting with Class::DBI is for you to write
2975a subclass for your database connection, with each table-class inheriting
2976in turn from it.
2977
2978As well as encapsulating the connection information in one place,
2979this also allows you to override default behaviour or add additional
2980functionality across all of your classes.
2981
2982As the innards of Class::DBI are still in flux, you must exercise extreme
2983caution in overriding private methods of Class::DBI (those starting with
2984an underscore), unless they are explicitly mentioned in this documentation
2985as being safe to override. If you find yourself needing to do this,
2986then I would suggest that you ask on the mailing list about it, and
2987we'll see if we can either come up with a better approach, or provide
2988a new means to do whatever you need to do.
2989
2990=head1 CAVEATS
2991
2992=head2 Multi-Column Foreign Keys are not supported
2993
2994You can't currently add a relationship keyed on multiple columns.
2995You could, however, write a Relationship plugin to do this, and the
2996world would be eternally grateful...
2997
2998=head2 Don't change or inflate the value of your primary columns
2999
3000Altering your primary key column currently causes Bad Things to happen.
3001I should really protect against this.
3002
3003=head1 SUPPORTED DATABASES
3004
3005Theoretically Class::DBI should work with almost any standard RDBMS. Of
3006course, in the real world, we know that that's not true. It is known
3007to work with MySQL, PostgreSQL, Oracle and SQLite, each of which have
3008their own additional subclass on CPAN that you should explore if you're
3009using them:
3010
3011  L<Class::DBI::mysql>, L<Class::DBI::Pg>, L<Class::DBI::Oracle>,
3012  L<Class::DBI::SQLite>
3013
3014For the most part it's been reported to work with Sybase, although there
3015are some issues with multi-case column/table names. Beyond that lies
3016The Great Unknown(tm). If you have access to other databases, please
3017give this a test run, and let me know the results.
3018
3019L<Ima::DBI> (and hence Class::DBI) requires a database that supports
3020table aliasing and a DBI driver that supports placeholders. This means
3021it won't work with older releases of L<DBD::AnyData> (and any releases
3022of its predecessor L<DBD::RAM>), and L<DBD::Sybase> + FreeTDS may or
3023may not work depending on your FreeTDS version.
3024
3025=head1 CURRENT AUTHOR
3026
3027Tony Bowden
3028
3029=head1 AUTHOR EMERITUS
3030
3031Michael G Schwern
3032
3033=head1 THANKS TO
3034
3035Tim Bunce, Tatsuhiko Miyagawa, Perrin Harkins, Alexander Karelas, Barry
3036Hoggard, Bart Lateur, Boris Mouzykantskii, Brad Bowman, Brian Parker,
3037Casey West, Charles Bailey, Christopher L. Everett Damian Conway, Dan
3038Thill, Dave Cash, David Jack Olrik, Dominic Mitchell, Drew Taylor,
3039Drew Wilson, Jay Strauss, Jesse Sheidlower, Jonathan Swartz, Marty
3040Pauley, Michael Styer, Mike Lambert, Paul Makepeace, Phil Crow, Richard
3041Piacentini, Simon Cozens, Simon Wilcox, Thomas Klausner, Tom Renfro,
3042Uri Gutman, William McKee, the Class::DBI mailing list, the POOP group,
3043and all the others who've helped, but that I've forgetten to mention.
3044
3045=head1 RELEASE PHILOSOPHY
3046
3047Class::DBI now uses a three-level versioning system. This release, for
3048example, is version 3.0.17
3049
3050The general approach to releases will be that users who like a degree of
3051stability can hold off on upgrades until the major sub-version increases
3052(e.g. 3.1.0). Those who like living more on the cutting edge can keep up
3053to date with minor sub-version releases.
3054
3055Functionality which was introduced during a minor sub-version release may
3056disappear without warning in a later minor sub-version release. I'll try
3057to avoid doing this, and will aim to have a deprecation cycle of at least
3058a few minor sub-versions, but you should keep a close eye on the CHANGES
3059file, and have good tests in place. (This is good advice generally,
3060of course.) Anything that is in a major sub-version release will go
3061through a deprecation cycle of at least one further major sub-version
3062before it is removed (and usually longer).
3063
3064=head2 Getting changes accepted
3065
3066There is an active Class::DBI community, however I am not part of it.
3067I am not on the mailing list, and I don't follow the wiki. I also do
3068not follow Perl Monks or CPAN reviews or annoCPAN or whatever the tool
3069du jour happens to be.
3070
3071If you find a problem with Class::DBI, by all means discuss it in any of
3072these places, but don't expect anything to happen unless you actually
3073tell me about it.
3074
3075The preferred method for doing this is via the CPAN RT interface, which
3076you can access at http://rt.cpan.org/ or by emailing
3077  bugs-Class-DBI@rt.cpan.org
3078
3079If you email me personally about Class::DBI issues, then I will
3080probably bounce them on to there, unless you specifically ask me not to.
3081Otherwise I can't keep track of what all needs fixed. (This of course
3082means that if you ask me not to send your mail to RT, there's a much
3083higher chance that nothing will every happen about your problem).
3084
3085=head2 Bug Reports
3086
3087If you're reporting a bug then it has a much higher chance of getting
3088fixed quicker if you can include a failing test case. This should be
3089a completely stand-alone test that could be added to the Class::DBI
3090distribution. That is, it should use L<Test::Simple> or L<Test::More>,
3091fail with the current code, but pass when I fix the problem. If it
3092needs to have a working database to show the problem, then this should
3093preferably use SQLite, and come with all the code to set this up. The
3094nice people on the mailing list will probably help you out if you need
3095assistance putting this together.
3096
3097You don't need to include code for actually fixing the problem, but of
3098course it's often nice if you can. I may choose to fix it in a different
3099way, however, so it's often better to ask first whether I'd like a
3100patch, particularly before spending a lot of time hacking.
3101
3102=head2 Patches
3103
3104If you are sending patches, then please send either the entire code
3105that is being changed or the output of 'diff -Bub'.  Please also note
3106what version the patch is against. I tend to apply all patches manually,
3107so I'm more interested in being able to see what you're doing than in
3108being able to apply the patch cleanly. Code formatting isn't an issue,
3109as I automagically run perltidy against the source after any changes,
3110so please format for clarity.
3111
3112Patches have a much better chance of being applied if they are small.
3113People often think that it's better for me to get one patch with a bunch
3114of fixes. It's not. I'd much rather get 100 small patches that can be
3115applied one by one. A change that I can make and release in five minutes
3116is always better than one that needs a couple of hours to ponder and work
3117through.
3118
3119I often reject patches that I don't like. Please don't take it personally.
3120I also like time to think about the wider implications of changes. Often
3121a I<lot> of time. Feel free to remind me about things that I may have
3122forgotten about, but as long as they're on rt.cpan.org I will get around
3123to them eventually.
3124
3125=head2 Feature Requests
3126
3127Wish-list requests are fine, although you should probably discuss them
3128on the mailing list (or equivalent) with others first. There's quite
3129often a plugin somewhere that already does what you want.
3130
3131In general I am much more open to discussion on how best to provide the
3132flexibility for you to make your Cool New Feature(tm) a plugin rather
3133than adding it to Class::DBI itself.
3134
3135For the most part the core of Class::DBI already has most of the
3136functionality that I believe it will ever need (and some more besides,
3137that will probably be split off at some point). Most other things are much
3138better off as plugins, with a separate life on CPAN or elsewhere (and with
3139me nowhere near the critical path). Most of the ongoing work on Class::DBI
3140is about making life easier for people to write extensions - whether
3141they're local to your own codebase or released for wider consumption.
3142
3143=head1 SUPPORT
3144
3145Support for Class::DBI is mostly via the mailing list.
3146
3147To join the list, or read the archives, visit
3148  http://lists.digitalcraftsmen.net/mailman/listinfo/classdbi
3149
3150There is also a Class::DBI wiki at
3151  http://www.class-dbi.com/
3152
3153The wiki contains much information that should probably be in these docs
3154but isn't yet. (See above if you want to help to rectify this.)
3155
3156As mentioned above, I don't follow the list or the wiki, so if you want
3157to contact me individually, then you'll have to track me down personally.
3158
3159There are lots of 3rd party subclasses and plugins available.
3160For a list of the ones on CPAN see:
3161  http://search.cpan.org/search?query=Class%3A%3ADBI&mode=module
3162
3163An article on Class::DBI was published on Perl.com a while ago. It's
3164slightly out of date , but it's a good introduction:
3165  http://www.perl.com/pub/a/2002/11/27/classdbi.html
3166
3167The wiki has numerous references to other articles, presentations etc.
3168
3169http://poop.sourceforge.net/ provides a document comparing a variety
3170of different approaches to database persistence, such as Class::DBI,
3171Alazabo, Tangram, SPOPS etc.
3172
3173=head1 LICENSE
3174
3175This library is free software; you can redistribute it and/or modify
3176it under the same terms as Perl itself.
3177
3178=head1 SEE ALSO
3179
3180Class::DBI is built on top of L<Ima::DBI>, L<DBIx::ContextualFetch>,
3181L<Class::Accessor> and L<Class::Data::Inheritable>. The innards and
3182much of the interface are easier to understand if you have an idea of
3183how they all work as well.
3184
3185=cut
3186
3187