| Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/SQL/Translator/Schema/Object.pm |
| Statements | Executed 9261 statements in 10.3ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 379 | 2 | 2 | 9.32ms | 44.0ms | SQL::Translator::Schema::Object::init |
| 387 | 9 | 9 | 2.22ms | 3.29ms | SQL::Translator::Schema::Object::_attributes |
| 1 | 1 | 1 | 595µs | 703µs | SQL::Translator::Schema::Object::BEGIN@40 |
| 11 | 1 | 1 | 113µs | 540µs | SQL::Translator::Schema::Object::equals |
| 5 | 2 | 2 | 46µs | 46µs | SQL::Translator::Schema::Object::extra |
| 1 | 1 | 1 | 15µs | 19µs | SQL::Translator::Schema::Object::BEGIN@36 |
| 1 | 1 | 1 | 11µs | 11µs | SQL::Translator::Schema::Object::BEGIN@37 |
| 1 | 1 | 1 | 8µs | 76µs | SQL::Translator::Schema::Object::BEGIN@38 |
| 1 | 1 | 1 | 7µs | 55µs | SQL::Translator::Schema::Object::BEGIN@39 |
| 1 | 1 | 1 | 7µs | 22µs | SQL::Translator::Schema::Object::BEGIN@42 |
| 0 | 0 | 0 | 0s | 0s | SQL::Translator::Schema::Object::_compare_objects |
| 0 | 0 | 0 | 0s | 0s | SQL::Translator::Schema::Object::remove_extra |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package SQL::Translator::Schema::Object; | ||||
| 2 | |||||
| 3 | # ---------------------------------------------------------------------- | ||||
| 4 | # Copyright (C) 2002-2009 SQLFairy Authors | ||||
| 5 | # | ||||
| 6 | # This program is free software; you can redistribute it and/or | ||||
| 7 | # modify it under the terms of the GNU General Public License as | ||||
| 8 | # published by the Free Software Foundation; version 2. | ||||
| 9 | # | ||||
| 10 | # This program is distributed in the hope that it will be useful, but | ||||
| 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of | ||||
| 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||||
| 13 | # General Public License for more details. | ||||
| 14 | # | ||||
| 15 | # You should have received a copy of the GNU General Public License | ||||
| 16 | # along with this program; if not, write to the Free Software | ||||
| 17 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | ||||
| 18 | # 02111-1307 USA | ||||
| 19 | # ------------------------------------------------------------------- | ||||
| 20 | |||||
| 21 | =pod | ||||
| 22 | |||||
| 23 | =head1 NAME | ||||
| 24 | |||||
| 25 | SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects. | ||||
| 26 | |||||
| 27 | =head1 SYNOPSIS | ||||
| 28 | |||||
| 29 | =head1 DESCSIPTION | ||||
| 30 | |||||
| 31 | Base class for Schema objects. Sub classes L<Class::Base> and adds the following | ||||
| 32 | extra functionality. | ||||
| 33 | |||||
| 34 | =cut | ||||
| 35 | |||||
| 36 | 3 | 19µs | 2 | 22µs | # spent 19µs (15+4) within SQL::Translator::Schema::Object::BEGIN@36 which was called:
# once (15µs+4µs) by base::import at line 36 # spent 19µs making 1 call to SQL::Translator::Schema::Object::BEGIN@36
# spent 3µs making 1 call to strict::import |
| 37 | 3 | 26µs | 1 | 11µs | # spent 11µs within SQL::Translator::Schema::Object::BEGIN@37 which was called:
# once (11µs+0s) by base::import at line 37 # spent 11µs making 1 call to SQL::Translator::Schema::Object::BEGIN@37 |
| 38 | 3 | 19µs | 2 | 76µs | # spent 76µs (8+68) within SQL::Translator::Schema::Object::BEGIN@38 which was called:
# once (8µs+68µs) by base::import at line 38 # spent 76µs making 1 call to SQL::Translator::Schema::Object::BEGIN@38
# spent 68µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 68µs |
| 39 | 3 | 21µs | 2 | 55µs | # spent 55µs (7+48) within SQL::Translator::Schema::Object::BEGIN@39 which was called:
# once (7µs+48µs) by base::import at line 39 # spent 55µs making 1 call to SQL::Translator::Schema::Object::BEGIN@39
# spent 48µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 48µs |
| 40 | 3 | 129µs | 2 | 707µs | # spent 703µs (595+108) within SQL::Translator::Schema::Object::BEGIN@40 which was called:
# once (595µs+108µs) by base::import at line 40 # spent 703µs making 1 call to SQL::Translator::Schema::Object::BEGIN@40
# spent 3µs making 1 call to Class::MakeMethods::Utility::Ref::import |
| 41 | |||||
| 42 | 3 | 339µs | 2 | 38µs | # spent 22µs (7+15) within SQL::Translator::Schema::Object::BEGIN@42 which was called:
# once (7µs+15µs) by base::import at line 42 # spent 22µs making 1 call to SQL::Translator::Schema::Object::BEGIN@42
# spent 15µs making 1 call to vars::import |
| 43 | |||||
| 44 | 1 | 400ns | $VERSION = '1.59'; | ||
| 45 | |||||
| 46 | |||||
| 47 | =head1 Construction | ||||
| 48 | |||||
| 49 | Derived classes should declare their attributes using the C<_attributes> | ||||
| 50 | method. They can then inherit the C<init> method from here which will call | ||||
| 51 | accessors of the same name for any values given in the hash passed to C<new>. | ||||
| 52 | Note that you will have to impliment the accessors your self and we expect perl | ||||
| 53 | style methods; call with no args to get and with arg to set. | ||||
| 54 | |||||
| 55 | e.g. If we setup our class as follows; | ||||
| 56 | |||||
| 57 | package SQL::Translator::Schema::Table; | ||||
| 58 | use base qw/SQL::Translator::Schema::Object/; | ||||
| 59 | |||||
| 60 | __PACKAGE__->_attributes( qw/schema name/ ); | ||||
| 61 | |||||
| 62 | sub name { ... } | ||||
| 63 | sub schema { ... } | ||||
| 64 | |||||
| 65 | Then we can construct it with | ||||
| 66 | |||||
| 67 | my $table = SQL::Translator::Schema::Table->new( | ||||
| 68 | schema => $schema, | ||||
| 69 | name => 'foo', | ||||
| 70 | ); | ||||
| 71 | |||||
| 72 | and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >> | ||||
| 73 | to set it up. Any undefined args will be ignored. | ||||
| 74 | |||||
| 75 | Multiple calls to C<_attributes> are cumulative and sub classes will inherit | ||||
| 76 | their parents attribute names. | ||||
| 77 | |||||
| 78 | This is currently experimental, but will hopefull go on to form an introspection | ||||
| 79 | API for the Schema objects. | ||||
| 80 | |||||
| 81 | =cut | ||||
| 82 | |||||
| 83 | |||||
| 84 | 1 | 6µs | 1 | 15µs | __PACKAGE__->mk_classdata("__attributes"); # spent 15µs making 1 call to Class::Data::Inheritable::mk_classdata |
| 85 | |||||
| 86 | # Define any global attributes here | ||||
| 87 | 1 | 2µs | 1 | 4µs | __PACKAGE__->__attributes([qw/extra/]); # spent 4µs making 1 call to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23] |
| 88 | |||||
| 89 | # Set the classes attribute names. Multiple calls are cumulative. | ||||
| 90 | # We need to be careful to create a new ref so that all classes don't end up | ||||
| 91 | # with the same ref and hence the same attributes! | ||||
| 92 | # spent 3.29ms (2.22+1.07) within SQL::Translator::Schema::Object::_attributes which was called 387 times, avg 9µs/call:
# 379 times (2.06ms+808µs) by SQL::Translator::Schema::Object::init at line 102, avg 8µs/call
# once (23µs+42µs) by SQL::Translator::Schema::BEGIN@50 at line 65 of SQL/Translator/Schema/Table.pm
# once (23µs+37µs) by SQL::Translator::Schema::Table::BEGIN@44 at line 96 of SQL/Translator/Schema/Field.pm
# once (23µs+33µs) by SQL::Translator::BEGIN@39 at line 61 of SQL/Translator/Schema.pm
# once (20µs+33µs) by SQL::Translator::Schema::Table::BEGIN@43 at line 64 of SQL/Translator/Schema/Constraint.pm
# once (16µs+37µs) by SQL::Translator::Schema::BEGIN@51 at line 61 of SQL/Translator/Schema/Trigger.pm
# once (21µs+28µs) by SQL::Translator::Schema::BEGIN@49 at line 59 of SQL/Translator/Schema/Procedure.pm
# once (14µs+32µs) by SQL::Translator::Schema::Table::BEGIN@45 at line 66 of SQL/Translator/Schema/Index.pm
# once (14µs+26µs) by SQL::Translator::Schema::BEGIN@52 at line 55 of SQL/Translator/Schema/View.pm | ||||
| 93 | 1161 | 2.10ms | my $class = shift; | ||
| 94 | 16 | 254µs | if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); } # spent 254µs making 16 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 16µs/call | ||
| 95 | 387 | 821µs | return @{$class->__attributes}; # spent 821µs making 387 calls to Class::Data::Inheritable::__ANON__[Class/Data/Inheritable.pm:23], avg 2µs/call | ||
| 96 | } | ||||
| 97 | |||||
| 98 | # Call accessors for any args in hashref passed | ||||
| 99 | # spent 44.0ms (9.32+34.7) within SQL::Translator::Schema::Object::init which was called 379 times, avg 116µs/call:
# 312 times (7.70ms+29.5ms) by Class::Base::new at line 59 of Class/Base.pm, avg 119µs/call
# 67 times (1.62ms+5.17ms) by SQL::Translator::Schema::Constraint::init at line 95 of SQL/Translator/Schema/Constraint.pm, avg 101µs/call | ||||
| 100 | 1137 | 1.52ms | my ( $self, $config ) = @_; | ||
| 101 | |||||
| 102 | 379 | 2.87ms | for my $arg ( $self->_attributes ) { # spent 2.87ms making 379 calls to SQL::Translator::Schema::Object::_attributes, avg 8µs/call | ||
| 103 | 6844 | 5.91ms | next unless defined $config->{$arg}; | ||
| 104 | 2256 | 31.8ms | defined $self->$arg( $config->{$arg} ) or return; # spent 5.86ms making 240 calls to SQL::Translator::Schema::Field::is_nullable, avg 24µs/call
# spent 5.16ms making 240 calls to SQL::Translator::Schema::Field::size, avg 22µs/call
# spent 5.10ms making 240 calls to SQL::Translator::Schema::Field::name, avg 21µs/call
# spent 4.98ms making 240 calls to SQL::Translator::Schema::Field::is_foreign_key, avg 21µs/call
# spent 2.77ms making 240 calls to SQL::Translator::Schema::Field::table, avg 12µs/call
# spent 2.50ms making 67 calls to SQL::Translator::Schema::Constraint::fields, avg 37µs/call
# spent 910µs making 240 calls to SQL::Translator::Schema::Field::data_type, avg 4µs/call
# spent 843µs making 67 calls to SQL::Translator::Schema::Constraint::table, avg 13µs/call
# spent 619µs making 240 calls to SQL::Translator::Schema::Field::is_auto_increment, avg 3µs/call
# spent 601µs making 31 calls to SQL::Translator::Schema::Index::fields, avg 19µs/call
# spent 504µs making 67 calls to SQL::Translator::Schema::Constraint::type, avg 8µs/call
# spent 438µs making 29 calls to SQL::Translator::Schema::Constraint::reference_fields, avg 15µs/call
# spent 402µs making 31 calls to SQL::Translator::Schema::Index::table, avg 13µs/call
# spent 300µs making 35 calls to SQL::Translator::Schema::Table::name, avg 9µs/call
# spent 123µs making 29 calls to SQL::Translator::Schema::Index::type, avg 4µs/call
# spent 122µs making 55 calls to SQL::Translator::Schema::Field::default_value, avg 2µs/call
# spent 105µs making 32 calls to SQL::Translator::Schema::Constraint::name, avg 3µs/call
# spent 102µs making 2 calls to SQL::Translator::Schema::View::fields, avg 51µs/call
# spent 85µs making 31 calls to SQL::Translator::Schema::Index::name, avg 3µs/call
# spent 77µs making 29 calls to SQL::Translator::Schema::Constraint::reference_table, avg 3µs/call
# spent 75µs making 29 calls to SQL::Translator::Schema::Constraint::on_update, avg 3µs/call
# spent 73µs making 29 calls to SQL::Translator::Schema::Constraint::on_delete, avg 3µs/call
# spent 38µs making 3 calls to SQL::Translator::Schema::Object::extra, avg 13µs/call
# spent 12µs making 2 calls to SQL::Translator::Schema::View::schema, avg 6µs/call
# spent 12µs making 4 calls to SQL::Translator::Schema::translator, avg 3µs/call
# spent 8µs making 2 calls to SQL::Translator::Schema::View::sql, avg 4µs/call
# spent 5µs making 2 calls to SQL::Translator::Schema::View::name, avg 3µs/call | ||
| 105 | } | ||||
| 106 | |||||
| 107 | return $self; | ||||
| 108 | } | ||||
| 109 | |||||
| 110 | # ---------------------------------------------------------------------- | ||||
| 111 | # spent 46µs within SQL::Translator::Schema::Object::extra which was called 5 times, avg 9µs/call:
# 3 times (38µs+0s) by SQL::Translator::Schema::Object::init at line 104, avg 13µs/call
# 2 times (8µs+0s) by SQL::Translator::Producer::SQLite::create_view at line 139 of SQL/Translator/Producer/SQLite.pm, avg 4µs/call | ||||
| 112 | |||||
| 113 | =pod | ||||
| 114 | |||||
| 115 | =head1 Global Attributes | ||||
| 116 | |||||
| 117 | The following attributes are defined here, therefore all schema objects will | ||||
| 118 | have them. | ||||
| 119 | |||||
| 120 | =head2 extra | ||||
| 121 | |||||
| 122 | Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields). | ||||
| 123 | Call with no args to get all the extra data. | ||||
| 124 | Call with a single name arg to get the value of the named extra attribute, | ||||
| 125 | returned as a scalar. Call with a hash or hashref to set extra attributes. | ||||
| 126 | Returns a hash or a hashref. | ||||
| 127 | |||||
| 128 | $field->extra( qualifier => 'ZEROFILL' ); | ||||
| 129 | |||||
| 130 | $qualifier = $field->extra('qualifier'); | ||||
| 131 | |||||
| 132 | %extra = $field->extra; | ||||
| 133 | $extra = $field->extra; | ||||
| 134 | |||||
| 135 | =cut | ||||
| 136 | |||||
| 137 | 25 | 40µs | my $self = shift; | ||
| 138 | @_ = %{$_[0]} if ref $_[0] eq "HASH"; | ||||
| 139 | my $extra = $self->{'extra'} ||= {}; | ||||
| 140 | |||||
| 141 | 6 | 14µs | if (@_==1) { | ||
| 142 | return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ; | ||||
| 143 | } | ||||
| 144 | elsif (@_) { | ||||
| 145 | my %args = @_; | ||||
| 146 | while ( my ( $key, $value ) = each %args ) { | ||||
| 147 | $extra->{$key} = $value; | ||||
| 148 | } | ||||
| 149 | } | ||||
| 150 | |||||
| 151 | return wantarray ? %$extra : $extra; | ||||
| 152 | } | ||||
| 153 | |||||
| 154 | # ---------------------------------------------------------------------- | ||||
| 155 | sub remove_extra { | ||||
| 156 | |||||
| 157 | =head2 remove_extra | ||||
| 158 | |||||
| 159 | L</extra> can only be used to get or set "extra" attributes but not to | ||||
| 160 | remove some. Call with no args to remove all extra attributes that | ||||
| 161 | have been set before. Call with a list of key names to remove | ||||
| 162 | certain extra attributes only. | ||||
| 163 | |||||
| 164 | # remove all extra attributes | ||||
| 165 | $field->remove_extra(); | ||||
| 166 | |||||
| 167 | # remove timezone and locale attributes only | ||||
| 168 | $field->remove_extra(qw/timezone locale/); | ||||
| 169 | |||||
| 170 | =cut | ||||
| 171 | |||||
| 172 | my ( $self, @keys ) = @_; | ||||
| 173 | unless (@keys) { | ||||
| 174 | $self->{'extra'} = {}; | ||||
| 175 | } | ||||
| 176 | else { | ||||
| 177 | delete $self->{'extra'}{$_} for @keys; | ||||
| 178 | } | ||||
| 179 | } | ||||
| 180 | |||||
| 181 | # ---------------------------------------------------------------------- | ||||
| 182 | # spent 540µs (113+427) within SQL::Translator::Schema::Object::equals which was called 11 times, avg 49µs/call:
# 11 times (113µs+427µs) by SQL::Translator::Schema::Index::equals at line 262 of SQL/Translator/Schema/Index.pm, avg 49µs/call | ||||
| 183 | |||||
| 184 | =pod | ||||
| 185 | |||||
| 186 | =head2 equals | ||||
| 187 | |||||
| 188 | Determines if this object is the same as another. | ||||
| 189 | |||||
| 190 | my $isIdentical = $object1->equals( $object2 ); | ||||
| 191 | |||||
| 192 | =cut | ||||
| 193 | |||||
| 194 | 66 | 163µs | my $self = shift; | ||
| 195 | my $other = shift; | ||||
| 196 | |||||
| 197 | return 0 unless $other; | ||||
| 198 | 22 | 415µs | return 1 if overload::StrVal($self) eq overload::StrVal($other); # spent 415µs making 22 calls to overload::AddrRef, avg 19µs/call | ||
| 199 | 11 | 12µs | return 0 unless $other->isa( __PACKAGE__ ); # spent 12µs making 11 calls to UNIVERSAL::isa, avg 1µs/call | ||
| 200 | return 1; | ||||
| 201 | } | ||||
| 202 | |||||
| 203 | # ---------------------------------------------------------------------- | ||||
| 204 | sub _compare_objects { | ||||
| 205 | my $self = shift; | ||||
| 206 | my $obj1 = shift; | ||||
| 207 | my $obj2 = shift; | ||||
| 208 | my $result = (ref_compare($obj1, $obj2) == 0); | ||||
| 209 | # if ( !$result ) { | ||||
| 210 | # use Carp qw(cluck); | ||||
| 211 | # cluck("How did I get here?"); | ||||
| 212 | # use Data::Dumper; | ||||
| 213 | # $Data::Dumper::Maxdepth = 1; | ||||
| 214 | # print "obj1: ", Dumper($obj1), "\n"; | ||||
| 215 | # print "obj2: ", Dumper($obj2), "\n"; | ||||
| 216 | # } | ||||
| 217 | return $result; | ||||
| 218 | } | ||||
| 219 | |||||
| 220 | #============================================================================= | ||||
| 221 | |||||
| 222 | 1 | 4µs | 1; | ||
| 223 | |||||
| 224 | =pod | ||||
| 225 | |||||
| 226 | =head1 SEE ALSO | ||||
| 227 | |||||
| 228 | =head1 TODO | ||||
| 229 | |||||
| 230 | =head1 BUGS | ||||
| 231 | |||||
| 232 | =head1 AUTHOR | ||||
| 233 | |||||
| 234 | Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>, | ||||
| 235 | Mark Addison E<lt>mark.addison@itn.co.ukE<gt>. | ||||
| 236 | |||||
| 237 | =cut |