← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:53 2010

File /project/perl/lib/Class/DBI.pm
Statements Executed 22596
Statement Execution Time 445ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1363101ms173msClass::DBI::::_require_class Class::DBI::_require_class
4611162.1ms180msClass::DBI::::_live_object_key Class::DBI::_live_object_key
4611145.1ms78.1msClass::DBI::::_fresh_init Class::DBI::_fresh_init
9252242.6ms79.6msClass::DBI::::_attrs Class::DBI::_attrs
4631139.6ms213msClass::DBI::::get Class::DBI::get
4611126.7ms771msClass::DBI::::construct Class::DBI::construct
4631125.7ms86.3msClass::DBI::::_find_columns Class::DBI::_find_columns
4611124.8ms283msClass::DBI::::_init Class::DBI::_init
4643223.9ms64.4msClass::DBI::::primary_column Class::DBI::primary_column
4672121.4ms38.9msClass::DBI::::_attribute_exists Class::DBI::_attribute_exists
4633216.7ms16.7msClass::DBI::::_attribute_store Class::DBI::_attribute_store
11110.2ms863msClass::DBI::::sth_to_objects Class::DBI::sth_to_objects
461118.41ms8.41msClass::DBI::::is_changed Class::DBI::is_changed
1117.21ms778msClass::DBI::::_ids_to_objects Class::DBI::_ids_to_objects
4112.81ms8.65msClass::DBI::::_mk_column_accessors Class::DBI::_mk_column_accessors
461122.61ms2.61msClass::DBI::::CORE:sort Class::DBI::CORE:sort (opcode)
36211.99ms2.75msClass::DBI::::_make_method Class::DBI::_make_method
4111.35ms15.8msClass::DBI::::_set_columns Class::DBI::_set_columns
131341.21ms5.54msClass::DBI::::set_sql Class::DBI::set_sql
1522759µs2.46msClass::DBI::::add_trigger Class::DBI::add_trigger
1011607µs982µsClass::DBI::::accessor_name_for Class::DBI::accessor_name_for
111539µs10.6msClass::DBI::::_flesh Class::DBI::_flesh
1011538µs538µsClass::DBI::::_generate_search_sql Class::DBI::_generate_search_sql
511530µs2.03msClass::DBI::::_extend_meta Class::DBI::_extend_meta
1011486µs861µsClass::DBI::::mutator_name_for Class::DBI::mutator_name_for
522449µs1.22msClass::DBI::::_extend_class_data Class::DBI::_extend_class_data
211412µs4.75msClass::DBI::::transform_sql Class::DBI::transform_sql
422271µs735µsClass::DBI::::table Class::DBI::table
553241µs170msClass::DBI::::__ANON__[:1034] Class::DBI::__ANON__[:1034]
111239µs11.6msClass::DBI::::add_relationship_type Class::DBI::add_relationship_type
421199µs16.0msClass::DBI::::columns Class::DBI::columns
311149µs519µsClass::DBI::::find_column Class::DBI::find_column
912136µs136µsClass::DBI::::CORE:subst Class::DBI::CORE:subst (opcode)
111130µs1.02msClass::DBI::::set_db Class::DBI::set_db
1422127µs127µsClass::DBI::::CORE:match Class::DBI::CORE:match (opcode)
111123µs3.53msClass::DBI::::add_searcher Class::DBI::add_searcher
1011115µs115µsClass::DBI::::_column_class Class::DBI::_column_class
111110µs213µsClass::DBI::::meta_info Class::DBI::meta_info
11178µs120µsClass::DBI::::_default_attributes Class::DBI::_default_attributes
51166µs66µsClass::DBI::::clear_object_index Class::DBI::clear_object_index
11149µs287µsClass::DBI::::_essential Class::DBI::_essential
11145µs1.07msClass::DBI::::connection Class::DBI::connection
0000s0sClass::DBI::::BEGIN Class::DBI::BEGIN
0000s0sClass::DBI::::DESTROY Class::DBI::DESTROY
0000s0sClass::DBI::__::Base::::BEGINClass::DBI::__::Base::BEGIN
0000s0sClass::DBI::::__ANON__[:1008] Class::DBI::__ANON__[:1008]
0000s0sClass::DBI::::__ANON__[:1095] Class::DBI::__ANON__[:1095]
0000s0sClass::DBI::::__ANON__[:1127] Class::DBI::__ANON__[:1127]
0000s0sClass::DBI::::__ANON__[:38] Class::DBI::__ANON__[:38]
0000s0sClass::DBI::::__ANON__[:39] Class::DBI::__ANON__[:39]
0000s0sClass::DBI::::__ANON__[:416] Class::DBI::__ANON__[:416]
0000s0sClass::DBI::::__ANON__[:436] Class::DBI::__ANON__[:436]
0000s0sClass::DBI::::__ANON__[:437] Class::DBI::__ANON__[:437]
0000s0sClass::DBI::::__ANON__[:74] Class::DBI::__ANON__[:74]
0000s0sClass::DBI::::__ANON__[:948] Class::DBI::__ANON__[:948]
0000s0sClass::DBI::::__ANON__[:966] Class::DBI::__ANON__[:966]
0000s0sClass::DBI::::__ANON__[:968] Class::DBI::__ANON__[:968]
0000s0sClass::DBI::::__ANON__[:971] Class::DBI::__ANON__[:971]
0000s0sClass::DBI::::_add_data_type Class::DBI::_add_data_type
0000s0sClass::DBI::::_as_hash Class::DBI::_as_hash
0000s0sClass::DBI::::_attribute_delete Class::DBI::_attribute_delete
0000s0sClass::DBI::::_attribute_set Class::DBI::_attribute_set
0000s0sClass::DBI::::_auto_increment_value Class::DBI::_auto_increment_value
0000s0sClass::DBI::::_bind_param Class::DBI::_bind_param
0000s0sClass::DBI::::_carp Class::DBI::_carp
0000s0sClass::DBI::::_check_classes Class::DBI::_check_classes
0000s0sClass::DBI::::_class_autoupdate Class::DBI::_class_autoupdate
0000s0sClass::DBI::::_column_placeholder Class::DBI::_column_placeholder
0000s0sClass::DBI::::_croak Class::DBI::_croak
0000s0sClass::DBI::::_data_hash Class::DBI::_data_hash
0000s0sClass::DBI::::_db_error Class::DBI::_db_error
0000s0sClass::DBI::::_deflated_column Class::DBI::_deflated_column
0000s0sClass::DBI::::_do_search Class::DBI::_do_search
0000s0sClass::DBI::::_insert Class::DBI::_insert
0000s0sClass::DBI::::_insert_row Class::DBI::_insert_row
0000s0sClass::DBI::::_invalid_object_method Class::DBI::_invalid_object_method
0000s0sClass::DBI::::_my_iterator Class::DBI::_my_iterator
0000s0sClass::DBI::::_next_in_sequence Class::DBI::_next_in_sequence
0000s0sClass::DBI::::_obj_autoupdate Class::DBI::_obj_autoupdate
0000s0sClass::DBI::::_prepopulate_id Class::DBI::_prepopulate_id
0000s0sClass::DBI::::_search_delete Class::DBI::_search_delete
0000s0sClass::DBI::::_simple_bless Class::DBI::_simple_bless
0000s0sClass::DBI::::_single_row_select Class::DBI::_single_row_select
0000s0sClass::DBI::::_single_value_select Class::DBI::_single_value_select
0000s0sClass::DBI::::_undefined_primary Class::DBI::_undefined_primary
0000s0sClass::DBI::::_unique_entries Class::DBI::_unique_entries
0000s0sClass::DBI::::_update_line Class::DBI::_update_line
0000s0sClass::DBI::::_update_vals Class::DBI::_update_vals
0000s0sClass::DBI::::add_constraint Class::DBI::add_constraint
0000s0sClass::DBI::::add_constructor Class::DBI::add_constructor
0000s0sClass::DBI::::all_columns Class::DBI::all_columns
0000s0sClass::DBI::::any_changed Class::DBI::any_changed
0000s0sClass::DBI::::autoupdate Class::DBI::autoupdate
0000s0sClass::DBI::::constrain_column Class::DBI::constrain_column
0000s0sClass::DBI::::copy Class::DBI::copy
0000s0sClass::DBI::::count_all Class::DBI::count_all
0000s0sClass::DBI::::data_type Class::DBI::data_type
0000s0sClass::DBI::::dbi_commit Class::DBI::dbi_commit
0000s0sClass::DBI::::dbi_rollback Class::DBI::dbi_rollback
0000s0sClass::DBI::::delete Class::DBI::delete
0000s0sClass::DBI::::discard_changes Class::DBI::discard_changes
0000s0sClass::DBI::::find_or_create Class::DBI::find_or_create
0000s0sClass::DBI::::has_real_column Class::DBI::has_real_column
0000s0sClass::DBI::::id Class::DBI::id
0000s0sClass::DBI::::insert Class::DBI::insert
0000s0sClass::DBI::::make_read_only Class::DBI::make_read_only
0000s0sClass::DBI::::maximum_value_of Class::DBI::maximum_value_of
0000s0sClass::DBI::::minimum_value_of Class::DBI::minimum_value_of
0000s0sClass::DBI::::move Class::DBI::move
0000s0sClass::DBI::::normalize_column_values Class::DBI::normalize_column_values
0000s0sClass::DBI::::purge_dead_from_object_index Class::DBI::purge_dead_from_object_index
0000s0sClass::DBI::::remove_from_object_index Class::DBI::remove_from_object_index
0000s0sClass::DBI::::retrieve Class::DBI::retrieve
0000s0sClass::DBI::::retrieve_all Class::DBI::retrieve_all
0000s0sClass::DBI::::retrieve_from_sql Class::DBI::retrieve_from_sql
0000s0sClass::DBI::::search_like Class::DBI::search_like
0000s0sClass::DBI::::set Class::DBI::set
0000s0sClass::DBI::::stringify_self Class::DBI::stringify_self
0000s0sClass::DBI::::table_alias Class::DBI::table_alias
0000s0sClass::DBI::::update Class::DBI::update
0000s0sClass::DBI::::validate_column_values Class::DBI::validate_column_values
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Class::DBI::__::Base;
2
315µsrequire 5.006;
4
5316.6ms2101µsuse Class::Trigger 0.07;
# spent 88µs making 1 call to Class::Trigger::import # spent 13µs making 1 call to UNIVERSAL::VERSION
63109µs10suse base qw(Class::Accessor Class::Data::Inheritable Ima::DBI);
# spent 92.7ms making 1 call to base::import, recursion: max depth 3, time 92.7ms
7
8package Class::DBI;
9
104353µs2279µsuse version; $VERSION = qv('3.0.17');
# spent 236µs making 1 call to version::__ANON__[version.pm:32] # spent 43µs making 1 call to version::import
11
12378µs123µsuse strict;
# spent 23µs making 1 call to strict::import
13385µs1112µsuse warnings;
# spent 112µs making 1 call to warnings::import
14
153106µs10suse base "Class::DBI::__::Base";
# spent 26.6ms making 1 call to base::import, recursion: max depth 3, time 26.6ms
16
17322.1msuse Class::DBI::ColumnGrouper;
1831.43msuse Class::DBI::Query;
19358µsuse Carp ();
203101µs1163µsuse List::Util;
# spent 163µs making 1 call to Exporter::import
2135.27msuse Clone ();
2234.25msuse UNIVERSAL::moniker;
23
243164µs1143µsuse vars qw($Weaken_Is_Available);
# spent 143µs making 1 call to vars::import
25
26BEGIN {
27321µs $Weaken_Is_Available = 1;
28236µs eval {
29 require Scalar::Util;
30 import Scalar::Util qw(weaken);
# spent 421µs making 1 call to Exporter::import
31 };
32 if ($@) {
33 $Weaken_Is_Available = 0;
34 }
351166µs}
36
37use overload
38 '""' => sub { shift->stringify_self },
39 bool => sub { not shift->_undefined_primary },
403337µs1209µs fallback => 1;
# spent 209µs making 1 call to overload::import
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
59141µs173µs__PACKAGE__->mk_classdata('__hasa_rels' => {});
# spent 73µs making 1 call to Class::Data::Inheritable::mk_classdata
60
61{
62328µs my %deprecated = (
63 # accessor_name => 'accessor_name_for', # 3.0.7
64 # mutator_name => 'accessor_name_for', # 3.0.7
65 );
66
6732.99ms198µs no strict 'refs';
# spent 98µs making 1 call to strict::unimport
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#----------------------------------------------------------------------
81127µs160µs__PACKAGE__->mk_classdata('__AutoCommit');
# spent 60µs making 1 call to Class::Data::Inheritable::mk_classdata
82123µs154µs__PACKAGE__->mk_classdata('__hasa_list');
# spent 54µs making 1 call to Class::Data::Inheritable::mk_classdata
83122µs152µs__PACKAGE__->mk_classdata('_table');
# spent 52µs making 1 call to Class::Data::Inheritable::mk_classdata
84123µs152µs__PACKAGE__->mk_classdata('_table_alias');
# spent 52µs making 1 call to Class::Data::Inheritable::mk_classdata
85122µs153µs__PACKAGE__->mk_classdata('sequence');
# spent 53µs making 1 call to Class::Data::Inheritable::mk_classdata
86138µs289µs__PACKAGE__->mk_classdata('__grouper' => Class::DBI::ColumnGrouper->new());
# spent 53µs making 1 call to Class::Data::Inheritable::mk_classdata # spent 36µs making 1 call to Class::DBI::ColumnGrouper::new
87138µs153µs__PACKAGE__->mk_classdata('__data_type' => {});
# spent 53µs making 1 call to Class::Data::Inheritable::mk_classdata
88122µs148µs__PACKAGE__->mk_classdata('__driver');
# spent 48µs making 1 call to Class::Data::Inheritable::mk_classdata
89124µs152µs__PACKAGE__->mk_classdata('iterator_class' => 'Class::DBI::Iterator');
# spent 52µs making 1 call to Class::Data::Inheritable::mk_classdata
90123µs169µs__PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
# spent 69µs making 1 call to Class::Data::Inheritable::mk_classdata
91118µs13.53ms__PACKAGE__->add_searcher(search => "Class::DBI::Search::Basic",);
# spent 3.53ms making 1 call to Class::DBI::add_searcher
92
93120µs111.6ms__PACKAGE__->add_relationship_type(
# spent 11.6ms making 1 call to Class::DBI::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);
98141µs165µs__PACKAGE__->mk_classdata('__meta_info' => {});
# spent 65µs making 1 call to Class::Data::Inheritable::mk_classdata
99
100#----------------------------------------------------------------------
101# SQL we'll need
102#----------------------------------------------------------------------
103119µs1531µs__PACKAGE__->set_sql(MakeNewObj => <<'');
# spent 531µs making 1 call to Class::DBI::set_sql
104INSERT INTO __TABLE__ (%s)
105VALUES (%s)
106
107119µs1318µs__PACKAGE__->set_sql(update => <<"");
# spent 318µs making 1 call to Class::DBI::set_sql
108UPDATE __TABLE__
109SET %s
110WHERE __IDENTIFIER__
111
112119µs1451µs__PACKAGE__->set_sql(Nextval => <<'');
# spent 451µs making 1 call to Class::DBI::set_sql
113SELECT NEXTVAL ('%s')
114
115118µs1393µs__PACKAGE__->set_sql(SearchSQL => <<'');
# spent 393µs making 1 call to Class::DBI::set_sql
116SELECT %s
117FROM %s
118WHERE %s
119
120117µs1370µs__PACKAGE__->set_sql(RetrieveAll => <<'');
# spent 370µs making 1 call to Class::DBI::set_sql
121SELECT __ESSENTIAL__
122FROM __TABLE__
123
124117µs1378µs__PACKAGE__->set_sql(Retrieve => <<'');
# spent 378µs making 1 call to Class::DBI::set_sql
125SELECT __ESSENTIAL__
126FROM __TABLE__
127WHERE %s
128
129117µs1376µs__PACKAGE__->set_sql(Flesh => <<'');
# spent 376µs making 1 call to Class::DBI::set_sql
130SELECT %s
131FROM __TABLE__
132WHERE __IDENTIFIER__
133
134118µs1384µs__PACKAGE__->set_sql(single => <<'');
# spent 384µs making 1 call to Class::DBI::set_sql
135SELECT %s
136FROM __TABLE__
137
138119µs1301µs__PACKAGE__->set_sql(DeleteMe => <<"");
# spent 301µs making 1 call to Class::DBI::set_sql
139DELETE
140FROM __TABLE__
141WHERE __IDENTIFIER__
142
143
144127µs153µs__PACKAGE__->mk_classdata('sql_transformer_class');
# spent 53µs making 1 call to Class::Data::Inheritable::mk_classdata
145118µs127µs__PACKAGE__->sql_transformer_class('Class::DBI::SQL::Transformer');
# spent 27µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
146
147# Override transform_sql from Ima::DBI to provide some extra
148# transformations
149
# spent 4.75ms (412µs+4.34) within Class::DBI::transform_sql which was called 2 times, avg 2.37ms/call: # 2 times (412µs+4.34ms) by Ima::DBI::__ANON__[/project/perl/lib/Ima/DBI.pm:384] at line 380 of Ima/DBI.pm, avg 2.37ms/call
sub transform_sql {
15010353µs my ($self, $sql, @args) = @_;
151 my $tclass = $self->sql_transformer_class;
# spent 58µs making 2 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 29µs/call
152 $self->_require_class($tclass);
# spent 2.45ms making 2 calls to Class::DBI::_require_class, avg 1.23ms/call
153 my $T = $tclass->new($self, $sql, @args);
# spent 93µs making 2 calls to Class::DBI::SQL::Transformer::new, avg 46µs/call
154 return $self->SUPER::transform_sql($T->sql => $T->args);
# spent 1.64ms making 2 calls to Class::DBI::SQL::Transformer::sql, avg 818µs/call # spent 51µs making 2 calls to Ima::DBI::transform_sql, avg 26µs/call # spent 45µs making 2 calls to Class::DBI::SQL::Transformer::args, avg 22µs/call
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
182
# spent 1.07ms (45µs+1.02) within Class::DBI::connection which was called # once (45µs+1.02ms) by base::import at line 13 of K2/DB2.pm
sub connection {
183242µs my $class = shift;
184 $class->set_db(Main => @_);
# spent 1.02ms making 1 call to Class::DBI::set_db
185}
186
187{
188222µs my %Per_DB_Attr_Defaults = (
189 pg => { AutoCommit => 0 },
190 oracle => { AutoCommit => 0 },
191 );
192
193
# spent 120µs (78+42) within Class::DBI::_default_attributes which was called # once (78µs+42µs) by Ima::DBI::_add_default_attributes at line 286 of Ima/DBI.pm
sub _default_attributes {
194272µs 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 } || {} },
# spent 26µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23] # spent 16µs making 1 call to Ima::DBI::_default_attributes
202 );
203 }
204}
205
206
# spent 1.02ms (130µs+893µs) within Class::DBI::set_db which was called # once (130µs+893µs) by Class::DBI::connection at line 184
sub set_db {
2074138µs 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;
# spent 12µs making 1 call to Class::DBI::CORE:match
211 $class->__driver($driver);
# spent 155µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
212 $class->SUPER::set_db('Main', $data_source, $user, $password, $attr);
# spent 726µs making 1 call to Ima::DBI::set_db
213}
214
215
# spent 735µs (271+464) within Class::DBI::table which was called 4 times, avg 184µs/call: # 2 times (166µs+410µs) by Class::DBI::Pg::set_up_table at line 80 of Class/DBI/Pg.pm, avg 288µs/call # 2 times (105µs+54µs) by Class::DBI::SQL::Transformer::_expand_table at line 71 of Class/DBI/SQL/Transformer.pm, avg 80µs/call
sub table {
21620251µs my ($proto, $table, $alias) = @_;
217 my $class = ref $proto || $proto;
218 $class->_table($table) if $table;
# spent 359µs making 2 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 180µs/call
219 $class->table_alias($alias) if $alias;
220 return $class->_table || $class->_table($class->table_alias);
# spent 105µs making 4 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 26µs/call
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
230
# spent 16.0ms (199µs+15.8) within Class::DBI::columns which was called 4 times, avg 4.00ms/call: # 2 times (98µs+10.9ms) by Class::DBI::Pg::set_up_table at line 82 of Class/DBI/Pg.pm, avg 5.51ms/call # 2 times (101µs+4.89ms) by Class::DBI::Pg::set_up_table at line 81 of Class/DBI/Pg.pm, avg 2.49ms/call
sub columns {
23116202µs my $proto = shift;
232 my $class = ref $proto || $proto;
233 my $group = shift || "All";
234 return $class->_set_columns($group => @_) if @_;
# spent 15.8ms making 4 calls to Class::DBI::_set_columns, avg 3.95ms/call
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
24110140µs
# spent 115µs within Class::DBI::_column_class which was called 10 times, avg 12µs/call: # 10 times (115µs+0s) by Class::DBI::_set_columns at line 246, avg 12µs/call
sub _column_class { 'Class::DBI::Column' }
242
243
# spent 15.8ms (1.35+14.5) within Class::DBI::_set_columns which was called 4 times, avg 3.95ms/call: # 4 times (1.35ms+14.5ms) by Class::DBI::columns at line 234, avg 3.95ms/call
sub _set_columns {
244201.27ms my ($class, $group, @columns) = @_;
245
246 my @cols = map ref $_ ? $_ : $class->_column_class->new($_), @columns;
# spent 1.81ms making 10 calls to Class::DBI::Column::new, avg 182µs/call # spent 115µs making 10 calls to Class::DBI::_column_class, avg 12µs/call
247
248 # Careful to take copy
249 $class->__grouper(Class::DBI::ColumnGrouper->clone($class->__grouper)
# spent 2.45ms making 4 calls to Class::DBI::ColumnGrouper::add_group, avg 613µs/call # spent 903µs making 4 calls to Class::DBI::ColumnGrouper::clone, avg 226µs/call # spent 525µs making 8 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 66µs/call
250 ->add_group($group => @cols));
251 $class->_mk_column_accessors(@cols);
# spent 8.65ms making 4 calls to Class::DBI::_mk_column_accessors, avg 2.16ms/call
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
273
# spent 64.4ms (23.9+40.5) within Class::DBI::primary_column which was called 464 times, avg 139µs/call: # 461 times (23.7ms+40.2ms) by Class::DBI::_live_object_key at line 521, avg 139µs/call # 2 times (138µs+186µs) by Class::DBI::_make_method at line 368, avg 162µs/call # once (55µs+89µs) by Class::DBI::SQL::Transformer::_do_transformation at line 120 of Class/DBI/SQL/Transformer.pm
sub primary_column {
274139221.9ms my $self = shift;
275 my @primary_columns = $self->__grouper->primary;
# spent 28.8ms making 464 calls to Class::DBI::ColumnGrouper::primary, avg 62µs/call # spent 11.7ms making 464 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 25µs/call
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}
28317µs*primary_columns = \&primary_column;
284
285142µs2238µs
# spent 287µs (49+238) within Class::DBI::_essential which was called # once (49µs+238µs) by Class::DBI::SQL::Transformer::_do_transformation at line 116 of Class/DBI/SQL/Transformer.pm
sub _essential { shift->__grouper->essential }
# spent 211µs making 1 call to Class::DBI::ColumnGrouper::essential # spent 27µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
286
287
# spent 519µs (149+370) within Class::DBI::find_column which was called 3 times, avg 173µs/call: # 3 times (149µs+370µs) by Class::DBI::Relationship::HasA::remap_arguments at line 11 of Class/DBI/Relationship/HasA.pm, avg 173µs/call
sub find_column {
2886144µs my ($class, $want) = @_;
289 return $class->__grouper->find_column($want);
# spent 291µs making 3 calls to Class::DBI::ColumnGrouper::find_column, avg 97µs/call # spent 79µs making 3 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 26µs/call
290}
291
292
# spent 86.3ms (25.7+60.7) within Class::DBI::_find_columns which was called 463 times, avg 186µs/call: # 463 times (25.7ms+60.7ms) by Class::DBI::get at line 841, avg 186µs/call
sub _find_columns {
293138923.3ms my $class = shift;
294 my $cg = $class->__grouper;
# spent 13.1ms making 463 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 28µs/call
295 return map $cg->find_column($_), @_;
# spent 47.6ms making 463 calls to Class::DBI::ColumnGrouper::find_column, avg 103µs/call
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
329
# spent 8.65ms (2.81+5.84) within Class::DBI::_mk_column_accessors which was called 4 times, avg 2.16ms/call: # 4 times (2.81ms+5.84ms) by Class::DBI::_set_columns at line 251, avg 2.16ms/call
sub _mk_column_accessors {
3308103µs my $class = shift;
331 foreach my $col (@_) {
332
333601.02ms10148µs my $default_accessor = $col->accessor;
# spent 148µs making 10 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 15µs/call
334
335 my $acc = $class->accessor_name_for($col);
# spent 982µs making 10 calls to Class::DBI::accessor_name_for, avg 98µs/call
336 my $mut = $class->mutator_name_for($col);
# spent 861µs making 10 calls to Class::DBI::mutator_name_for, avg 86µs/call
337
338 my %method = ();
339
34030383µs 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);
# spent 230µs making 10 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 23µs/call
346 $col->mutator($acc);
# spent 223µs making 10 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 22µs/call
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) {
357501.15ms my $name = $method{$type};
358 my $acc_type = "make${type}accessor";
359 my $accessor = $class->$acc_type($col->name_lc);
# spent 395µs making 10 calls to Class::DBI::Column::name_lc, avg 40µs/call # spent 255µs making 10 calls to Class::Accessor::make_accessor, avg 26µs/call
360 $class->_make_method($_, $accessor) for ($name, "_${name}_accessor");
# spent 2.75ms making 20 calls to Class::DBI::_make_method, avg 137µs/call
361 }
362 }
363}
364
365
# spent 2.75ms (1.99+763µs) within Class::DBI::_make_method which was called 36 times, avg 76µs/call: # 20 times (1.65ms+1.10ms) by Class::DBI::_mk_column_accessors at line 360, avg 137µs/call # 16 times (338µs+-338µs) by Class::DBI::_make_method at line 373, avg 0s/call
sub _make_method {
3661202.28ms my ($class, $name, $method) = @_;
367 return if defined &{"$class\::$name"};
368117µs18677µs $class->_carp("Column '$name' in $class clashes with built-in method")
# spent 353µs making 16 calls to UNIVERSAL::can, avg 22µs/call # spent 324µs making 2 calls to Class::DBI::primary_column, avg 162µs/call
369 if Class::DBI->can($name)
370 and not($name eq "id" and join(" ", $class->primary_columns) eq "id");
37136.65ms1100µs no strict 'refs';
# spent 100µs making 1 call to strict::unimport
372 *{"$class\::$name"} = $method;
373 $class->_make_method(lc $name => $method);
# spent 338µs making 16 calls to Class::DBI::_make_method, avg 21µs/call, recursion: max depth 1, time 338µs
374}
375
376
# spent 982µs (607+375) within Class::DBI::accessor_name_for which was called 10 times, avg 98µs/call: # 10 times (607µs+375µs) by Class::DBI::_mk_column_accessors at line 335, avg 98µs/call
sub accessor_name_for {
37730811µs my ($class, $column) = @_;
378 if ($class->can('accessor_name')) {
# spent 219µs making 10 calls to UNIVERSAL::can, avg 22µs/call
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;
# spent 156µs making 10 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 16µs/call
383}
384
385
# spent 861µs (486+375) within Class::DBI::mutator_name_for which was called 10 times, avg 86µs/call: # 10 times (486µs+375µs) by Class::DBI::_mk_column_accessors at line 336, avg 86µs/call
sub mutator_name_for {
38630706µs my ($class, $column) = @_;
387 if ($class->can('mutator_name')) {
# spent 218µs making 10 calls to UNIVERSAL::can, avg 22µs/call
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;
# spent 157µs making 10 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 16µs/call
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
44715µs*create = \&insert;
448
449#----------------------------------------------------------------------
450# Low Level Data Access
451#----------------------------------------------------------------------
452
453
# spent 79.6ms (42.6+36.9) within Class::DBI::_attrs which was called 925 times, avg 86µs/call: # 463 times (21.0ms+17.2ms) by Class::DBI::get at line 848, avg 83µs/call # 462 times (21.6ms+19.7ms) by Class::DBI::Relationship::HasA::__ANON__[/project/perl/lib/Class/DBI/Relationship/HasA.pm:77] at line 36 of Class/DBI/Relationship/HasA.pm, avg 89µs/call
sub _attrs {
454185012.5ms my ($self, @atts) = @_;
455113.9ms return @{$self}{@atts};
456}
45716µs*_attr = \&_attrs;
458
459
# spent 16.7ms (16.7+47µs) within Class::DBI::_attribute_store which was called 463 times, avg 36µs/call: # 461 times (16.5ms+0s) by Class::DBI::_fresh_init at line 505, avg 36µs/call # once (74µs+47µs) by Class::DBI::Relationship::HasA::__ANON__[/project/perl/lib/Class/DBI/Relationship/HasA.pm:77] at line 55 of Class/DBI/Relationship/HasA.pm # once (70µs+0s) by Class::DBI::_flesh at line 858
sub _attribute_store {
460185217.9ms my $self = shift;
46117µs 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
483
# spent 38.9ms (21.4+17.5) within Class::DBI::_attribute_exists which was called 467 times, avg 83µs/call: # 463 times (21.3ms+17.3ms) by Class::DBI::get at line 844, avg 83µs/call # 4 times (168µs+148µs) by Class::DBI::_flesh at line 854, avg 79µs/call
sub _attribute_exists {
4849345.88ms my ($self, $attribute) = @_;
48517.34ms exists $self->{$attribute};
486}
487
488#----------------------------------------------------------------------
489# Live Object Index (using weak refs if available)
490#----------------------------------------------------------------------
491
49214µsmy %Live_Objects;
49315µsmy $Init_Count = 0;
494
495
# spent 283ms (24.8+259) within Class::DBI::_init which was called 461 times, avg 615µs/call: # 461 times (24.8ms+259ms) by Class::DBI::construct at line 716, avg 615µs/call
sub _init {
496184424.0ms my $class = shift;
497 my $data = shift || {};
498 my $key = $class->_live_object_key($data);
# spent 180ms making 461 calls to Class::DBI::_live_object_key, avg 391µs/call
499 return $Live_Objects{$key} || $class->_fresh_init($key => $data);
# spent 78.1ms making 461 calls to Class::DBI::_fresh_init, avg 169µs/call
500}
501
502
# spent 78.1ms (45.1+33.1) within Class::DBI::_fresh_init which was called 461 times, avg 169µs/call: # 461 times (45.1ms+33.1ms) by Class::DBI::_init at line 499, avg 169µs/call
sub _fresh_init {
503230526.6ms my ($class, $key, $data) = @_;
504 my $obj = bless {}, $class;
505 $obj->_attribute_store(%$data);
# spent 16.5ms making 461 calls to Class::DBI::_attribute_store, avg 36µs/call
506
507 # don't store it unless all keys are present
50892220.7ms if ($key && $Weaken_Is_Available) {
509 weaken($Live_Objects{$key} = $obj);
# spent 4.37ms making 461 calls to Scalar::Util::weaken, avg 9µs/call
510
511 # time to clean up your room?
512 $class->purge_dead_from_object_index
# spent 12.2ms making 461 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 26µs/call
513 if ++$Init_Count % $class->purge_object_index_every == 0;
514 }
515 return $obj;
516}
517
518
# spent 180ms (62.1+118) within Class::DBI::_live_object_key which was called 461 times, avg 391µs/call: # 461 times (62.1ms+118ms) by Class::DBI::_init at line 498, avg 391µs/call
sub _live_object_key {
519230525.9ms my ($me, $data) = @_;
520 my $class = ref($me) || $me;
521 my @primary = $class->primary_columns;
# spent 63.9ms making 461 calls to Class::DBI::primary_column, avg 139µs/call
522
523 # no key unless all PK columns are defined
52413.49ms return "" unless @primary == grep defined $data->{$_}, @primary;
525
526 # create single unique key for this object
527112.1ms4612.61ms return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary;
# spent 2.61ms making 461 calls to Class::DBI::CORE:sort, avg 6µs/call
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
540
# spent 66µs within Class::DBI::clear_object_index which was called 5 times, avg 13µs/call: # 5 times (66µs+0s) by Class::DBI::Relationship::_init at line 23 of Class/DBI/Relationship.pm, avg 13µs/call
sub clear_object_index {
541578µs %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
713
# spent 771ms (26.7+744) within Class::DBI::construct which was called 461 times, avg 1.67ms/call: # 461 times (26.7ms+744ms) by Class::DBI::_ids_to_objects at line 1159, avg 1.67ms/call
sub construct {
714230526.3ms my ($proto, $data) = @_;
715 my $class = ref $proto || $proto;
716 my $self = $class->_init($data);
# spent 283ms making 461 calls to Class::DBI::_init, avg 615µs/call
717 $self->call_trigger('select');
# spent 461ms making 461 calls to Class::Trigger::call_trigger, avg 1000µs/call
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 {
81592210.4ms my ($self) = shift;
816 if (my @changed = $self->is_changed) {
# spent 8.41ms making 461 calls to Class::DBI::is_changed, avg 18µs/call
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
837
# spent 213ms (39.6+174) within Class::DBI::get which was called 463 times, avg 460µs/call: # 463 times (39.6ms+174ms) by Class::Accessor::__ANON__[/project/perl/lib/Class/Accessor.pm:395] at line 393 of Class/Accessor.pm, avg 460µs/call
sub get {
838277838.6ms my $self = shift;
839 return $self->_croak("Can't fetch data as class method") unless ref $self;
840
841 my @cols = $self->_find_columns(@_);
# spent 86.3ms making 463 calls to Class::DBI::_find_columns, avg 186µs/call
842 return $self->_croak("Can't get() nothing!") unless @cols;
843
844 if (my @fetch_cols = grep !$self->_attribute_exists($_), @cols) {
# spent 38.6ms making 463 calls to Class::DBI::_attribute_exists, avg 83µs/call # spent 10.6ms making 1 call to Class::DBI::_flesh # spent 114µs making 1 call to Class::DBI::ColumnGrouper::groups_for # spent 25µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
845 $self->_flesh($self->__grouper->groups_for(@fetch_cols));
846 }
847
848 return $self->_attrs(@cols);
# spent 38.3ms making 463 calls to Class::DBI::_attrs, avg 83µs/call
849}
850
851
# spent 10.6ms (539µs+10.1) within Class::DBI::_flesh which was called # once (539µs+10.1ms) by Class::DBI::get at line 844
sub _flesh {
8524138µs my ($self, @groups) = @_;
853 my @real = grep $_ ne "TEMP", @groups;
8544128µs61.04ms if (my @want = grep !$self->_attribute_exists($_),
# spent 699µs making 1 call to Class::DBI::ColumnGrouper::columns_in # spent 316µs making 4 calls to Class::DBI::_attribute_exists, avg 79µs/call # spent 27µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
855 $self->__grouper->columns_in(@real)) {
856 my %row;
8571114µs34.52ms @row{@want} = $self->sql_Flesh(join ", ", @want)->select_row($self->id);
# spent 2.11ms making 1 call to Ima::DBI::__ANON__[Ima/DBI.pm:384] # spent 1.96ms making 1 call to DBIx::ContextualFetch::st::select_row # spent 458µs making 1 call to Class::Accessor::__ANON__[Class/Accessor.pm:395]
858 $self->_attribute_store(\%row);
# spent 70µs making 1 call to Class::DBI::_attribute_store
859 $self->call_trigger('select');
# spent 4.21ms making 1 call to Class::Trigger::call_trigger
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
891
# spent 8.41ms within Class::DBI::is_changed which was called 461 times, avg 18µs/call: # 461 times (8.41ms+0s) by Class::DBI::DESTROY at line 816, avg 18µs/call
sub is_changed {
8929229.19ms 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.
930
# spent 5.54ms (1.21+4.33) within Class::DBI::set_sql which was called 13 times, avg 426µs/call: # once (110µs+483µs) by Class::DBI::Plugin::RetrieveAll::import at line 69 of Class/DBI/Plugin/RetrieveAll.pm # once (117µs+472µs) by main::BEGIN at line 29 of Wiki/DB/Wiki.pm # once (97µs+434µs) by base::import at line 103 # once (91µs+360µs) by base::import at line 112 # once (113µs+316µs) by main::BEGIN at line 35 of Wiki/DB/Wiki.pm # once (100µs+327µs) by Class::DBI::Plugin::AbstractCount::init at line 13 of Class/DBI/Plugin/AbstractCount.pm # once (89µs+304µs) by base::import at line 115 # once (99µs+285µs) by base::import at line 134 # once (83µs+295µs) by base::import at line 124 # once (87µs+289µs) by base::import at line 129 # once (86µs+284µs) by base::import at line 120 # once (69µs+249µs) by base::import at line 107 # once (71µs+230µs) by base::import at line 138
sub set_sql {
931651.32ms my ($class, $name, $sql, $db, @others) = @_;
932 $db ||= 'Main';
933 $class->SUPER::set_sql($name, $sql, $db, @others);
# spent 3.67ms making 13 calls to Ima::DBI::set_sql, avg 283µs/call
934 $class->_generate_search_sql($name) if $sql =~ /select/i;
# spent 538µs making 10 calls to Class::DBI::_generate_search_sql, avg 54µs/call # spent 115µs making 13 calls to Class::DBI::CORE:match, avg 9µs/call
935 return 1;
936}
937
938
# spent 538µs within Class::DBI::_generate_search_sql which was called 10 times, avg 54µs/call: # 10 times (538µs+0s) by Class::DBI::set_sql at line 934, avg 54µs/call
sub _generate_search_sql {
93950568µs 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";
94431.38ms1105µs no strict 'refs';
# spent 105µs making 1 call to strict::unimport
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
1012
# spent 2.46ms (759µs+1.70) within Class::DBI::add_trigger which was called 15 times, avg 164µs/call: # 14 times (689µs+1.59ms) by Class::DBI::Relationship::_add_triggers at line 53 of Class/DBI/Relationship.pm, avg 163µs/call # once (70µs+112µs) by main::BEGIN at line 11 of Wiki/DB/Wiki.pm
sub add_trigger {
101360745µs 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);
# spent 1.70ms making 15 calls to Class::Trigger::add_trigger, avg 113µs/call
1020}
1021
1022#----------------------------------------------------------------------
1023# Inflation
1024#----------------------------------------------------------------------
1025
1026
# spent 11.6ms (239µs+11.4) within Class::DBI::add_relationship_type which was called # once (239µs+11.4ms) by base::import at line 93
sub add_relationship_type {
1027243µs my ($self, %rels) = @_;
1028 while (my ($name, $class) = each %rels) {
10296172µs311.4ms $self->_require_class($class);
# spent 11.4ms making 3 calls to Class::DBI::_require_class, avg 3.80ms/call
103031.06ms1101µs no strict 'refs';
# spent 101µs making 1 call to strict::unimport
1031
# spent 170ms (241µs+170) within Class::DBI::__ANON__[/project/perl/lib/Class/DBI.pm:1034] which was called 5 times, avg 34.0ms/call: # once (63µs+114ms) by K2::DB2::has_a_datetime at line 50 of K2/DB2.pm # once (45µs+47.5ms) by main::BEGIN at line 8 of Wiki/DB/Wiki.pm # once (58µs+3.12ms) by Class::DBI::_require_class at line 8 of Wiki/DB/WikiCategories.pm # once (35µs+2.93ms) by Class::DBI::_require_class at line 9 of Wiki/DB/WikiCategories.pm # once (40µs+2.35ms) by main::BEGIN at line 9 of Wiki/DB/Wiki.pm
*{"$self\::$name"} = sub {
103210219µs my $proto = shift;
1033 $class->set_up($name => $proto => @_);
# spent 170ms making 5 calls to Class::DBI::Relationship::set_up, avg 34.0ms/call, recursion: max depth 1, time 6.05ms
1034 };
1035 }
1036}
1037
1038
# spent 2.03ms (530µs+1.50) within Class::DBI::_extend_meta which was called 5 times, avg 407µs/call: # 5 times (530µs+1.50ms) by Class::DBI::Relationship::_set_up_class_data at line 42 of Class/DBI/Relationship.pm, avg 407µs/call
sub _extend_meta {
1039201.25ms my ($class, $type, $subtype, $val) = @_;
1040 my %hash = %{ Clone::clone($class->__meta_info || {}) };
# spent 833µs making 5 calls to Clone::clone, avg 167µs/call # spent 132µs making 5 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 26µs/call
1041119µs $hash{$type}->{$subtype} = $val;
1042 $class->__meta_info(\%hash);
# spent 410µs making 5 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 82µs/call
1043}
1044
1045
# spent 213µs (110+103) within Class::DBI::meta_info which was called # once (110µs+103µs) by Class::DBI::Relationship::HasA::__ANON__[/project/perl/lib/Class/DBI/Relationship/HasA.pm:77] at line 37 of Class/DBI/Relationship/HasA.pm
sub meta_info {
1046543µs my ($class, $type, $subtype) = @_;
1047 my $meta = $class->__meta_info;
# spent 28µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23]
1048 return $meta unless $type;
104915µs return $meta->{$type} unless $subtype;
1050117µs 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
1086
# spent 3.53ms (123µs+3.41) within Class::DBI::add_searcher which was called # once (123µs+3.41ms) by base::import at line 91
sub add_searcher {
1087239µs my ($self, %rels) = @_;
1088 while (my ($name, $class) = each %rels) {
1089393µs13.39ms $self->_require_class($class);
# spent 3.39ms making 1 call to Class::DBI::_require_class
1090 $self->_croak("$class is not a valid Searcher")
# spent 11µs making 1 call to UNIVERSAL::can
1091 unless $class->can('run_search');
10923428µs196µs no strict 'refs';
# spent 96µs making 1 call to strict::unimport
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;
112031.65ms191µs no strict 'refs';
# spent 91µs making 1 call to strict::unimport
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
1130
# spent 863ms (10.2+853) within Class::DBI::sth_to_objects which was called # once (10.2ms+853ms) by Class::DBI::Plugin::RetrieveAll::__ANON__[/project/perl/lib/Class/DBI/Plugin/RetrieveAll.pm:77] at line 76 of Class/DBI/Plugin/RetrieveAll.pm
sub sth_to_objects {
11317132µs my ($class, $sth, $args) = @_;
1132 $class->_croak("sth_to_objects needs a statement handle") unless $sth;
1133 unless (UNIVERSAL::isa($sth => "DBI::st")) {
# spent 19µs making 1 call to UNIVERSAL::isa
1134 my $meth = "sql_$sth";
1135 $sth = $class->$meth();
1136 }
1137 my (%data, @rows);
11383261µs eval {
1139 $sth->execute(@$args) unless $sth->{Active};
# spent 56.3ms making 1 call to DBIx::ContextualFetch::st::execute # spent 14µs making 1 call to DBI::common::FETCH
1140124µs3286µs $sth->bind_columns(\(@data{ @{ $sth->{NAME_lc} } }));
# spent 155µs making 1 call to DBI::st::bind_columns # spent 131µs making 2 calls to DBI::common::FETCH, avg 66µs/call
114119.72ms46217.9ms push @rows, {%data} while $sth->fetch;
# spent 17.9ms making 462 calls to DBIx::ContextualFetch::st::fetch, avg 39µs/call
1142 };
1143 return $class->_croak("$class can't $sth->{Statement}: $@", err => $@)
1144 if $@;
1145 return $class->_ids_to_objects(\@rows);
# spent 778ms making 1 call to Class::DBI::_ids_to_objects
1146}
114716µs*_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
1156
# spent 778ms (7.21+771) within Class::DBI::_ids_to_objects which was called # once (7.21ms+771ms) by Class::DBI::sth_to_objects at line 1145
sub _ids_to_objects {
115736.67ms my ($class, $data) = @_;
1158 return $#$data + 1 unless defined wantarray;
1159 return map $class->construct($_), @$data if wantarray;
# spent 771ms making 461 calls to Class::DBI::construct, avg 1.67ms/call
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
1206
# spent 1.22ms (449µs+774µs) within Class::DBI::_extend_class_data which was called 5 times, avg 245µs/call: # 3 times (306µs+540µs) by Class::DBI::Relationship::HasA::_set_up_class_data at line 94 of Class/DBI/Relationship/HasA.pm, avg 282µs/call # 2 times (143µs+234µs) by Class::DBI::Relationship::HasMany::_set_up_class_data at line 57 of Class/DBI/Relationship/HasMany.pm, avg 189µs/call
sub _extend_class_data {
120720346µs my ($class, $struct, $key, $value) = @_;
1208 my %hash = %{ $class->$struct() || {} };
# spent 132µs making 5 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 26µs/call
1209121µs $hash{$key} = $value;
1210 $class->$struct(\%hash);
# spent 524µs making 5 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 105µs/call
1211}
1212
121315µsmy %required_classes; # { required_class => class_that_last_required_it, ... }
1214
1215
# spent 173ms (101+72.0) within Class::DBI::_require_class which was called 13 times, avg 13.3ms/call: # 3 times (71.1ms+39.4ms) by Class::DBI::Relationship::HasA::triggers at line 19 of Class/DBI/Relationship/HasA.pm, avg 36.9ms/call # 3 times (6.72ms+4.66ms) by Class::DBI::add_relationship_type at line 1029, avg 3.80ms/call # 2 times (12.8ms+24.8ms) by Class::DBI::Relationship::HasMany::remap_arguments at line 26 of Class/DBI/Relationship/HasMany.pm, avg 18.8ms/call # 2 times (5.81ms+1.52ms) by Class::DBI::Relationship::HasMany::triggers at line 71 of Class/DBI/Relationship/HasMany.pm, avg 3.66ms/call # 2 times (2.28ms+173µs) by Class::DBI::transform_sql at line 152, avg 1.23ms/call # once (2.05ms+1.35ms) by Class::DBI::add_searcher at line 1089
sub _require_class {
121657968µs my ($self, $load_class) = @_;
1217 $required_classes{$load_class} ||= my $for_class = ref($self) || $self;
1218
1219 # return quickly if class already exists
12203511µs1105µs no strict 'refs';
# spent 105µs making 1 call to strict::unimport
1221 return if exists ${"$load_class\::"}{ISA};
1222 (my $load_module = $load_class) =~ s!::!/!g;
# spent 136µs making 9 calls to Class::DBI::CORE:subst, avg 15µs/call
1223946.3ms 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
1246162µs1;
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
# spent 127µs within Class::DBI::CORE:match which was called 14 times, avg 9µs/call: # 13 times (115µs+0s) by Class::DBI::set_sql at line 934 of Class/DBI.pm, avg 9µs/call # once (12µs+0s) by Class::DBI::set_db at line 210 of Class/DBI.pm
sub Class::DBI::CORE:match; # xsub
# spent 2.61ms within Class::DBI::CORE:sort which was called 461 times, avg 6µs/call: # 461 times (2.61ms+0s) by Class::DBI::_live_object_key at line 527 of Class/DBI.pm, avg 6µs/call
sub Class::DBI::CORE:sort; # xsub
# spent 136µs within Class::DBI::CORE:subst which was called 9 times, avg 15µs/call: # 9 times (136µs+0s) by Class::DBI::_require_class at line 1222 of Class/DBI.pm, avg 15µs/call
sub Class::DBI::CORE:subst; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.