name
701
|
|
|
|
|
|
|
my $profile = $_->{Profiles}; |
702
|
|
|
|
|
|
|
print $user->id, " has address: ", $profile->address; |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
The above only does 1 SELECT. Note that the join search function |
706
|
|
|
|
|
|
|
returns an array of hashes that map from the SQL table name to the |
707
|
|
|
|
|
|
|
DBIx::OO instance. |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
You can pass additional WHERE, ORDER, LIMIT and OFFSET clauses to the |
710
|
|
|
|
|
|
|
join functions as well: |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
@data = Users->search_join_profile({ 'Users.last_name' => 'Doe' }, |
713
|
|
|
|
|
|
|
'Users.nickname', |
714
|
|
|
|
|
|
|
10); |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
The above fetches the first 10 members of the Doe family ordered by |
717
|
|
|
|
|
|
|
nickname. |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
Due to lack of support from SQL::Abstract side, the JOIN is actually a |
720
|
|
|
|
|
|
|
select like this: |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
SELECT ... FROM table1, table2 WHERE table1.foreign = table2.id |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
In the future I hope to add better support for this, that is, use |
725
|
|
|
|
|
|
|
"INNER JOIN" and eventually support other JOIN types as well. |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
=head3 Notes |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=over |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
=item 1. |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
The C accessors will actually retrieve data at each call. |
734
|
|
|
|
|
|
|
Therefore: |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
$p1 = $user->fk_pages; |
737
|
|
|
|
|
|
|
$p2 = $user->fk_pages; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
will retrieve 2 different arrays, containing different sets of objects |
740
|
|
|
|
|
|
|
(even if they point to the same records), hitting the database twice. |
741
|
|
|
|
|
|
|
This is subject to change, but for now you have to be careful about |
742
|
|
|
|
|
|
|
this. It's best to keep a reference to the returned object(s) rather |
743
|
|
|
|
|
|
|
than calling fk_pages() all over the place. |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=item 2. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
has_many() creates accessors that select multiple objects. The |
748
|
|
|
|
|
|
|
database will be hit once, though, and multiple objects are created |
749
|
|
|
|
|
|
|
from the returned data. If this isn't desirable, feel free to LIMIT |
750
|
|
|
|
|
|
|
your results. |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
=back |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
=cut |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
### TODO: this can be optimized: cache the where clause and generated SQL. |
757
|
|
|
|
|
|
|
sub has_a { |
758
|
0
|
|
|
0
|
1
|
|
my ($class, $name, $type, $arg, $order) = @_; |
759
|
0
|
|
|
|
|
|
my $fk_name = $class->get_fk_name($name); |
760
|
2
|
|
|
2
|
|
12
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1771
|
|
761
|
0
|
|
|
|
|
|
my $colmap; |
762
|
|
|
|
|
|
|
my $mk_colmap = sub { |
763
|
0
|
0
|
|
0
|
|
|
if (!defined $colmap) { |
764
|
0
|
|
|
|
|
|
my ($class) = @_; |
765
|
0
|
|
|
|
|
|
$colmap = {}; |
766
|
0
|
0
|
|
|
|
|
if (!$arg) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
767
|
0
|
|
|
|
|
|
$colmap->{$name} = $type->columns('P')->[0]; |
768
|
|
|
|
|
|
|
} elsif (!ref $arg) { |
769
|
0
|
|
|
|
|
|
$colmap->{$class->columns('P')->[0]} = $arg; |
770
|
|
|
|
|
|
|
} elsif (ref $arg eq 'HASH') { |
771
|
0
|
|
|
|
|
|
$colmap = $arg; |
772
|
|
|
|
|
|
|
} elsif (ref $arg eq 'ARRAY') { |
773
|
0
|
|
|
|
|
|
@{$colmap}{@$arg} = @{$type->columns('P')}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
} |
776
|
0
|
|
|
|
|
|
}; |
777
|
|
|
|
|
|
|
## declare the fk_colname function |
778
|
|
|
|
|
|
|
{ |
779
|
0
|
|
|
|
|
|
*{"$class\::$fk_name"} = sub { |
|
0
|
|
|
|
|
|
|
780
|
0
|
|
|
0
|
|
|
my ($self, $order2) = @_; |
781
|
0
|
0
|
|
|
|
|
$order2 = $order |
782
|
|
|
|
|
|
|
if !defined $order2; |
783
|
0
|
|
|
|
|
|
&$mk_colmap($self); |
784
|
0
|
|
|
|
|
|
my %where; |
785
|
0
|
|
|
|
|
|
@where{values %$colmap} = @{$self->{values}}{keys %$colmap}; |
|
0
|
|
|
|
|
|
|
786
|
0
|
|
|
|
|
|
my $a = $type->search(\%where, $order, 1); |
787
|
0
|
|
|
|
|
|
return $a->[0]; |
788
|
0
|
|
|
|
|
|
}; |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
## simple 2 tables JOIN facility |
791
|
|
|
|
|
|
|
{ |
792
|
0
|
|
|
|
|
|
my %join_colmap; |
|
0
|
|
|
|
|
|
|
793
|
0
|
|
|
|
|
|
my ($t1, $t2); |
794
|
0
|
|
|
|
|
|
my ($c1, $c2); |
795
|
0
|
|
|
|
|
|
my @cols; |
796
|
0
|
|
|
|
|
|
*{"$class\::search_join_${name}"} = sub { |
797
|
0
|
|
|
0
|
|
|
my ($class, $where2, $order2, $limit, $offset) = @_; |
798
|
0
|
0
|
|
|
|
|
$order2 = $order |
799
|
|
|
|
|
|
|
if !defined $order2; |
800
|
0
|
|
|
|
|
|
my $sa = $class->get_sql_abstract; |
801
|
0
|
0
|
|
|
|
|
if (!%join_colmap) { |
802
|
0
|
|
|
|
|
|
&$mk_colmap($class); |
803
|
0
|
|
|
|
|
|
($t1, $t2) = ($class->table, $type->table); |
804
|
0
|
|
|
|
|
|
$c1 = $class->_get_columns([ 'P', 'E' ]); |
805
|
0
|
|
|
|
|
|
$c2 = $type->_get_columns([ 'P', 'E' ]); |
806
|
0
|
|
|
|
|
|
@cols = map { "$t1.$_" } @$c1; |
|
0
|
|
|
|
|
|
|
807
|
0
|
|
|
|
|
|
push(@cols, |
808
|
0
|
|
|
|
|
|
map { "$t2.$_" } @$c2); |
809
|
0
|
|
|
|
|
|
my @k = map { "$t1.$_" } keys %$colmap; |
|
0
|
|
|
|
|
|
|
810
|
0
|
|
|
|
|
|
my @v = map { my $tmp = '= ' . $sa->_quote("$t2.$_"); |
|
0
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
|
\$tmp } values %$colmap; |
812
|
0
|
|
|
|
|
|
@join_colmap{@k} = @v; |
813
|
|
|
|
|
|
|
} |
814
|
0
|
|
|
|
|
|
my %where = %join_colmap; |
815
|
0
|
0
|
|
|
|
|
@where{keys %$where2} = values %$where2 |
816
|
|
|
|
|
|
|
if $where2; |
817
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->select([ $t1, $t2 ], |
818
|
|
|
|
|
|
|
\@cols, \%where, $order2, $limit, $offset); |
819
|
0
|
|
|
|
|
|
my $sth = $class->_run_sql($sql, \@bind); |
820
|
0
|
|
|
|
|
|
my @ret; |
821
|
0
|
|
|
|
|
|
my $slicepoint = scalar(@$c1) - 1; |
822
|
0
|
|
|
|
|
|
my $end = $slicepoint + scalar(@$c2); |
823
|
0
|
|
|
|
|
|
while (my $row = $sth->fetchrow_arrayref) { |
824
|
0
|
|
|
|
|
|
my $obj = {}; |
825
|
0
|
|
|
|
|
|
my $o1 = $obj->{$t1} = $class->new; |
826
|
0
|
|
|
|
|
|
my $o2 = $obj->{$t2} = $type->new; |
827
|
0
|
|
|
|
|
|
@{$o1->{values}}{@$c1} = @{$row}[0..$slicepoint]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
828
|
0
|
|
|
|
|
|
@{$o2->{values}}{@$c2} = @{$row}[$slicepoint+1..$end]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
829
|
0
|
|
|
|
|
|
push @ret, $obj; |
830
|
|
|
|
|
|
|
} |
831
|
0
|
|
|
|
|
|
return @ret; |
832
|
0
|
|
|
|
|
|
}; |
833
|
|
|
|
|
|
|
} |
834
|
0
|
|
|
|
|
|
undef $class; |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
=head2 C |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
Alias to has_a(). |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
=cut |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
*might_have = \&has_a; |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
### TODO: this can be optimized: cache the where clause and generated SQL. |
846
|
|
|
|
|
|
|
sub has_many { |
847
|
0
|
|
|
0
|
1
|
|
my ($class, $name, $type, $arg, $order, $limit, $offset) = @_; |
848
|
0
|
|
|
|
|
|
my $colmap; |
849
|
0
|
|
|
|
|
|
my $fk_name = $class->get_fk_name($name); |
850
|
2
|
|
|
2
|
|
14
|
no strict 'refs'; |
|
2
|
|
|
|
|
20
|
|
|
2
|
|
|
|
|
1278
|
|
851
|
|
|
|
|
|
|
my $mk_colmap = sub { |
852
|
0
|
0
|
|
0
|
|
|
if (!defined $colmap) { |
853
|
0
|
|
|
|
|
|
my $self = shift; |
854
|
0
|
|
|
|
|
|
$colmap = {}; |
855
|
0
|
0
|
|
|
|
|
if (!$arg) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
856
|
0
|
|
|
|
|
|
$colmap->{$name} = $type->columns('P')->[0]; |
857
|
|
|
|
|
|
|
} elsif (!ref $arg) { |
858
|
0
|
|
|
|
|
|
$colmap->{$self->columns('P')->[0]} = $arg; |
859
|
|
|
|
|
|
|
} elsif (ref $arg eq 'HASH') { |
860
|
0
|
|
|
|
|
|
$colmap = $arg; |
861
|
|
|
|
|
|
|
} elsif (ref $arg eq 'ARRAY') { |
862
|
0
|
|
|
|
|
|
@{$colmap}{@$arg} = @{$type->columns('P')}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
} |
865
|
0
|
|
|
|
|
|
}; |
866
|
0
|
|
|
|
|
|
*{"$class\::$fk_name"} = sub { |
867
|
0
|
|
|
0
|
|
|
my ($self, $where2, $order2, $limit2, $offset2) = @_; |
868
|
0
|
0
|
|
|
|
|
$order2 = $order |
869
|
|
|
|
|
|
|
if !defined $order2; |
870
|
0
|
0
|
|
|
|
|
$limit2 = $limit |
871
|
|
|
|
|
|
|
if !defined $limit2; |
872
|
0
|
0
|
|
|
|
|
$offset2 = $offset |
873
|
|
|
|
|
|
|
if !defined $offset2; |
874
|
0
|
|
|
|
|
|
&$mk_colmap($self); |
875
|
0
|
|
|
|
|
|
my %where; |
876
|
0
|
|
|
|
|
|
@where{values %$colmap} = @{$self->{values}}{keys %$colmap}; |
|
0
|
|
|
|
|
|
|
877
|
0
|
0
|
|
|
|
|
@where{keys %$where2} = values %$where2 |
878
|
|
|
|
|
|
|
if $where2; |
879
|
0
|
|
|
|
|
|
return $type->search(\%where, $order2, $limit2, $offset2); |
880
|
0
|
|
|
|
|
|
}; |
881
|
0
|
|
|
|
|
|
*{"$class\::add_to_$name"} = sub { |
882
|
0
|
|
|
0
|
|
|
my $self = shift; |
883
|
0
|
0
|
|
|
|
|
my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_; |
|
0
|
|
|
|
|
|
|
884
|
0
|
|
|
|
|
|
&$mk_colmap($self); |
885
|
0
|
|
|
|
|
|
@val{values %$colmap} = @{$self->{values}}{keys %$colmap}; |
|
0
|
|
|
|
|
|
|
886
|
0
|
|
|
|
|
|
return $type->create(\%val); |
887
|
0
|
|
|
|
|
|
}; |
888
|
0
|
|
|
|
|
|
*{"$class\::count_$name"} = sub { |
889
|
0
|
|
|
0
|
|
|
my $self = shift; |
890
|
0
|
0
|
|
|
|
|
my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_; |
|
0
|
|
|
|
|
|
|
891
|
0
|
|
|
|
|
|
&$mk_colmap($self); |
892
|
0
|
|
|
|
|
|
@val{values %$colmap} = @{$self->{values}}{keys %$colmap}; |
|
0
|
|
|
|
|
|
|
893
|
0
|
|
|
|
|
|
return $type->count(\%val); |
894
|
0
|
|
|
|
|
|
}; |
895
|
0
|
|
|
|
|
|
undef $class; |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=head2 C |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
You can use has_mapping to map one object to another using an |
901
|
|
|
|
|
|
|
intermediate table. You can have these tables: |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
Users: id, first_name, etc. |
904
|
|
|
|
|
|
|
Groups: id, description, etc. |
905
|
|
|
|
|
|
|
Users_To_Groups: user, group |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
This is quite classical, I suppose, to declare many-to-many |
908
|
|
|
|
|
|
|
relationships. The Users_To_Groups contains records that map one user |
909
|
|
|
|
|
|
|
to one group. To get the ID-s of all groups that a certain user |
910
|
|
|
|
|
|
|
belongs to, you would say: |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
SELECT group FROM Users_To_Group where user = '$user' |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
But since you usually need the Group objects directly, you could speed |
915
|
|
|
|
|
|
|
things up with a join: |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
SELECT Groups.id, Groups.description, ... FROM Groups, Users_To_Groups |
918
|
|
|
|
|
|
|
WHERE Users_To_Groups.group = Groups.id |
919
|
|
|
|
|
|
|
AND Users_To_Groups.user = '$user'; |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
The relationship declared with has_mapping() does exactly that. You |
922
|
|
|
|
|
|
|
would call it like this: |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
package Users; |
925
|
|
|
|
|
|
|
__PACKAGE__->table('Users'); |
926
|
|
|
|
|
|
|
__PACKAGE__->columns(P => [ 'id' ], ...); |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
__PACKAGE__->has_mapping(groups, 'Groups', |
929
|
|
|
|
|
|
|
'Users_To_Groups', 'user', 'group'); |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
package Groups; |
932
|
|
|
|
|
|
|
__PACKAGE__->table('Groups'); |
933
|
|
|
|
|
|
|
__PACKAGE__->columns(P => [ 'id' ], ...); |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# You can get the reverse mapping as well: |
936
|
|
|
|
|
|
|
__PACKAGE__->has_mapping(users, 'Users', |
937
|
|
|
|
|
|
|
'Users_To_Groups', 'group', 'user'); |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
package Users_To_Groups; |
940
|
|
|
|
|
|
|
__PACKAGE__->table('Users_To_Groups'); |
941
|
|
|
|
|
|
|
__PACKAGE__->columns(P => [ 'user', 'group' ]); |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
Note that Users_To_Groups has a multiple primary key. This isn't |
944
|
|
|
|
|
|
|
required, but you should at least have an unique index for the (user, |
945
|
|
|
|
|
|
|
group) pair. |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=head3 Arguments |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
I started with an example because the function itself is quite |
950
|
|
|
|
|
|
|
complicated. Here are arguments documentation: |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
=over |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
=item name |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
This is used to name the accessors. By default we will prepend a |
957
|
|
|
|
|
|
|
"fk_" (see L). |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
=item type |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
The type of the target objects. |
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
=item maptype |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
The mapping object type. This is the name of the object that maps one |
966
|
|
|
|
|
|
|
type to another. Even though you'll probably never need to |
967
|
|
|
|
|
|
|
instantiate such an object, it still has to be declared. |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
=item map1 |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
Specifies how we map from current package (__PACKAGE__) to the |
972
|
|
|
|
|
|
|
C object. This can be a scalar or an hash ref. If it's a |
973
|
|
|
|
|
|
|
scalar, we will assume that __PACKAGE__ has a simple primary key (not |
974
|
|
|
|
|
|
|
multiple) and C is the name of the column from C that |
975
|
|
|
|
|
|
|
we should map this key to. If it's a hash reference, it should |
976
|
|
|
|
|
|
|
directly specify the mapping; the keys will be taken from __PACKAGE__ |
977
|
|
|
|
|
|
|
and the values from C. If that sounds horrible, check the |
978
|
|
|
|
|
|
|
example below. |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
=item map2 |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
Similar to C, but C specifies the mapping from C |
983
|
|
|
|
|
|
|
to the target C. If a scalar, it will be the name of the column |
984
|
|
|
|
|
|
|
from C that maps to the primary key of the target package |
985
|
|
|
|
|
|
|
(assumed to be a simple primary key). If a hash reference, it |
986
|
|
|
|
|
|
|
specifies the full mapping. |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
=item order, limit, offset |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
Similar to has_many, these can specify default ORDER BY and/or |
991
|
|
|
|
|
|
|
LIMIT/OFFSET clauses for the resulted query. |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
=back |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
=head3 Example |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
Here's the mapping overview: |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
map1 map2 |
1000
|
|
|
|
|
|
|
__PACKAGE__ ===> C ===> C |
1001
|
|
|
|
|
|
|
current package table that holds the target package |
1002
|
|
|
|
|
|
|
the mapping |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
=cut |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
sub has_mapping { |
1007
|
0
|
|
|
0
|
1
|
|
my ($class, $name, $type, $maptype, $arg1, $arg2, $order, $limit, $offset) = @_; |
1008
|
0
|
|
|
|
|
|
my $fk_name = $class->get_fk_name($name); |
1009
|
2
|
|
|
2
|
|
13
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
6729
|
|
1010
|
0
|
|
|
|
|
|
my ($tcols, $select); |
1011
|
0
|
|
|
|
|
|
my @keys; |
1012
|
0
|
|
|
|
|
|
*{"$class\::$fk_name"} = sub { |
1013
|
0
|
|
|
0
|
|
|
my ($self, $order2, $limit2, $offset2) = @_; |
1014
|
0
|
0
|
|
|
|
|
$order2 = $order |
1015
|
|
|
|
|
|
|
if !defined $order2; |
1016
|
0
|
0
|
|
|
|
|
$limit2 = $limit |
1017
|
|
|
|
|
|
|
if !defined $limit2; |
1018
|
0
|
0
|
|
|
|
|
$offset2 = $offset |
1019
|
|
|
|
|
|
|
if !defined $offset2; |
1020
|
|
|
|
|
|
|
|
1021
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1022
|
0
|
|
|
|
|
|
my @bind; |
1023
|
0
|
0
|
|
|
|
|
if (!$select) { |
1024
|
0
|
0
|
|
|
|
|
if (!ref $arg1) { |
|
|
0
|
|
|
|
|
|
1025
|
0
|
|
|
|
|
|
my %tmp; |
1026
|
0
|
|
|
|
|
|
$tmp{$self->columns('P')->[0]} = $arg1; |
1027
|
0
|
|
|
|
|
|
$arg1 = \%tmp; |
1028
|
|
|
|
|
|
|
} elsif (ref $arg1 eq 'ARRAY') { |
1029
|
0
|
|
|
|
|
|
my %tmp; |
1030
|
0
|
|
|
|
|
|
@tmp{@{$self->columns('P')}} = @$arg1; |
|
0
|
|
|
|
|
|
|
1031
|
0
|
|
|
|
|
|
$arg1 = \%tmp; |
1032
|
|
|
|
|
|
|
} |
1033
|
0
|
0
|
|
|
|
|
if (!ref $arg2) { |
|
|
0
|
|
|
|
|
|
1034
|
0
|
|
|
|
|
|
my %tmp; |
1035
|
0
|
|
|
|
|
|
$tmp{$arg2} = $type->columns('P')->[0]; |
1036
|
0
|
|
|
|
|
|
$arg2 = \%tmp; |
1037
|
|
|
|
|
|
|
} elsif (ref $arg2 eq 'ARRAY') { |
1038
|
0
|
|
|
|
|
|
my %tmp; |
1039
|
0
|
|
|
|
|
|
@tmp{@$arg2} = @{$type->columns('P')}; |
|
0
|
|
|
|
|
|
|
1040
|
0
|
|
|
|
|
|
$arg2 = \%tmp; |
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
|
1043
|
0
|
|
|
|
|
|
my %where = (); |
1044
|
0
|
|
|
|
|
|
my ($st, $tt, $mt) = ($self->table, $type->table, $maptype->table); |
1045
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %$arg1) { |
1046
|
0
|
|
|
|
|
|
my $tmp = '= ' . $sa->_quote("$mt.$v"); |
1047
|
0
|
|
|
|
|
|
$where{"$st.$k"} = \$tmp; # SCALAR ref means literal SQL |
1048
|
0
|
|
|
|
|
|
$where{"$mt.$v"} = $self->get($k); |
1049
|
0
|
|
|
|
|
|
push @keys, $k; # remember these keys to reconstruct @bind later |
1050
|
|
|
|
|
|
|
} |
1051
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %$arg2) { |
1052
|
0
|
|
|
|
|
|
my $tmp = '= ' . $sa->_quote("$tt.$v"); |
1053
|
0
|
|
|
|
|
|
$where{"$mt.$k"} = \$tmp; # SCALAR ref means literal SQL |
1054
|
|
|
|
|
|
|
} |
1055
|
0
|
|
|
|
|
|
$tcols = $type->_get_columns([ 'P', 'E' ]); |
1056
|
0
|
|
|
|
|
|
my @fields = map { "$tt.$_" } @$tcols; |
|
0
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
|
1058
|
0
|
|
|
|
|
|
($select, @bind) = $sa->select([ $st, $mt, $tt ], \@fields, \%where); |
1059
|
|
|
|
|
|
|
} else { |
1060
|
0
|
|
|
|
|
|
@bind = $self->get(@keys); |
1061
|
|
|
|
|
|
|
} |
1062
|
0
|
|
|
|
|
|
my $sql = $select . $sa->order_and_limit($order2, $limit2, $offset2); |
1063
|
0
|
|
|
|
|
|
my $sth = $type->_run_sql($sql, \@bind); |
1064
|
0
|
|
|
|
|
|
my @ret; |
1065
|
0
|
|
|
|
|
|
while (my $row = $sth->fetchrow_arrayref) { |
1066
|
0
|
|
|
|
|
|
my $obj = $type->new; |
1067
|
0
|
|
|
|
|
|
@{$obj->{values}}{@$tcols} = @$row; |
|
0
|
|
|
|
|
|
|
1068
|
0
|
|
|
|
|
|
push @ret, $obj; |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
0
|
0
|
|
|
|
|
return wantarray ? @ret : \@ret; |
1072
|
0
|
|
|
|
|
|
}; |
1073
|
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
=head2 C |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
my $u = Users->create({ id => 'foo', |
1078
|
|
|
|
|
|
|
first_name => 'John', |
1079
|
|
|
|
|
|
|
last_name => 'Doe' }); |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
Creates a new record and stores it in the database. Returns the newly |
1082
|
|
|
|
|
|
|
created object. We recommend passing a hash reference, but you can |
1083
|
|
|
|
|
|
|
pass a hash by value as well. |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
=cut |
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
sub create { |
1088
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
1089
|
0
|
0
|
|
|
|
|
my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_; |
|
0
|
|
|
|
|
|
|
1090
|
0
|
|
|
|
|
|
my $class = __T($self); |
1091
|
|
|
|
|
|
|
|
1092
|
0
|
|
|
|
|
|
my $obj = $class->new; |
1093
|
0
|
|
|
|
|
|
$obj->before_set(\%val, 1); |
1094
|
0
|
|
|
|
|
|
$obj->{values} = \%val; |
1095
|
0
|
|
|
|
|
|
$obj->_apply_defaults; |
1096
|
|
|
|
|
|
|
|
1097
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1098
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->insert($self->table, \%val); |
1099
|
0
|
|
|
|
|
|
my $dbh = $self->get_dbh; |
1100
|
0
|
|
|
|
|
|
$self->_run_sql($sql, \@bind); |
1101
|
|
|
|
|
|
|
|
1102
|
0
|
|
|
|
|
|
my $pk = $self->columns('P'); |
1103
|
0
|
0
|
0
|
|
|
|
$val{$pk->[0]} = $self->_get_last_id($dbh) |
1104
|
|
|
|
|
|
|
if @$pk == 1 && !exists $val{$pk->[0]}; |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
# since users may specify SQL functions using an array ref, we |
1107
|
|
|
|
|
|
|
# remove them in order to get full values later. |
1108
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %val) { |
1109
|
0
|
0
|
|
|
|
|
delete $val{$k} |
1110
|
|
|
|
|
|
|
if ref $v; |
1111
|
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
|
|
1113
|
0
|
|
|
|
|
|
return $obj; |
1114
|
|
|
|
|
|
|
} |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
=head2 clone(@except) |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
Clones an object, returning a hash (reference) suitable for create(). |
1119
|
|
|
|
|
|
|
Here's how you would call it: |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
my $val = $page->clone; |
1122
|
|
|
|
|
|
|
my $new_page = Pages->create($val); |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
Or, supposing you don't want to copy the value of the "created" field: |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
my $val = $page->clone('created'); |
1127
|
|
|
|
|
|
|
my $new_page = Pages->create($val); |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
=cut |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
sub clone { |
1132
|
0
|
|
|
0
|
1
|
|
my ($self, @except) = @_; |
1133
|
0
|
|
|
|
|
|
my %val; |
1134
|
0
|
|
|
|
|
|
my $cols = $self->clone_columns(@except); |
1135
|
0
|
|
|
|
|
|
@val{@$cols} = $self->get(@$cols); |
1136
|
0
|
|
|
|
|
|
return \%val; |
1137
|
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
=head2 C |
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
Initializes one or more objects from the given data. $data can be a |
1142
|
|
|
|
|
|
|
hashref (in which case a single object will be created and returned) |
1143
|
|
|
|
|
|
|
or an arrayref (multiple objects will be created and returned as an |
1144
|
|
|
|
|
|
|
array reference). |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
The hashes simply contain the data, as retrieved from the database. |
1147
|
|
|
|
|
|
|
That is, map column name to field value. |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
This method is convenient in those cases where you already have the |
1150
|
|
|
|
|
|
|
data (suppose you SELECT-ed it in a different way than using DBIx::OO) |
1151
|
|
|
|
|
|
|
and want to initialize DBIx::OO objects without the penalty of going |
1152
|
|
|
|
|
|
|
through the DB again. |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
=cut |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
sub init_from_data { |
1157
|
0
|
|
|
0
|
1
|
|
my ($class, $data) = @_; |
1158
|
0
|
0
|
|
|
|
|
if (ref $data eq 'ARRAY') { |
1159
|
0
|
|
|
|
|
|
my @a = (); |
1160
|
0
|
|
|
|
|
|
foreach my $h (@$data) { |
1161
|
0
|
|
|
|
|
|
push @a, $class->init_from_data($h); |
1162
|
|
|
|
|
|
|
} |
1163
|
0
|
|
|
|
|
|
return \@a; |
1164
|
|
|
|
|
|
|
} else { |
1165
|
0
|
|
|
|
|
|
my $obj = $class->new; |
1166
|
0
|
|
|
|
|
|
$obj->{values} = $data; |
1167
|
0
|
|
|
|
|
|
return $obj; |
1168
|
|
|
|
|
|
|
} |
1169
|
|
|
|
|
|
|
} |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
=head2 C |
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
my $u = Users->retrieve('foo'); |
1174
|
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
|
Retrieves an object from the database. You need to pass its ID (the |
1176
|
|
|
|
|
|
|
value of the primary key). If the primary key consists on more |
1177
|
|
|
|
|
|
|
columns, you can pass the values in order as an array, or you can pass |
1178
|
|
|
|
|
|
|
a hash reference. |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
Returns undef if no objects were found. |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
=cut |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
sub retrieve { |
1185
|
0
|
|
|
0
|
1
|
|
my $class = __T($_[0]); |
1186
|
0
|
|
|
|
|
|
my $self = shift; |
1187
|
0
|
|
|
|
|
|
my $obj; |
1188
|
0
|
0
|
|
|
|
|
if (ref $self) { # refresh existing object |
1189
|
0
|
|
|
|
|
|
$obj = $self; |
1190
|
|
|
|
|
|
|
# reset values |
1191
|
0
|
|
|
|
|
|
$obj->{values} = $self->_get_pk_where; |
1192
|
0
|
|
|
|
|
|
$obj->{modified} = {}; |
1193
|
|
|
|
|
|
|
} else { # create new object |
1194
|
0
|
|
|
|
|
|
$obj = $class->new; |
1195
|
0
|
0
|
|
|
|
|
if (!ref $_[0]) { |
|
|
0
|
|
|
|
|
|
1196
|
0
|
|
|
|
|
|
my $pk = $class->columns('P'); |
1197
|
0
|
|
|
|
|
|
@{$obj->{values}}{@$pk} = @_; |
|
0
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
} elsif (ref $_[0] eq 'HASH') { |
1199
|
0
|
|
|
|
|
|
my ($h) = @_; |
1200
|
0
|
|
|
|
|
|
@{$obj->{values}}{keys %$h} = values %$h; |
|
0
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
} |
1202
|
|
|
|
|
|
|
} |
1203
|
0
|
|
|
|
|
|
eval { |
1204
|
0
|
|
|
|
|
|
$obj->_retrieve_columns([ 'P', 'E' ]); |
1205
|
|
|
|
|
|
|
}; |
1206
|
0
|
0
|
|
|
|
|
if ($@) { |
1207
|
|
|
|
|
|
|
### XXX: a warning should be in order here? We can't be sure |
1208
|
|
|
|
|
|
|
### why did the operation failed... |
1209
|
0
|
|
|
|
|
|
undef $obj; |
1210
|
|
|
|
|
|
|
} |
1211
|
0
|
|
|
|
|
|
return $obj; |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
=head2 C |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
$a = Users->search({ created => [ '>=', '2006-01-01 00:00:00' ]}); |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
Searches the database and returns an array of objects that match the |
1219
|
|
|
|
|
|
|
search criteria. All arguments are optional. If you pass no |
1220
|
|
|
|
|
|
|
arguments, it will return an array containing all objects in the DB. |
1221
|
|
|
|
|
|
|
The syntax of C<$where> and C<$order> are described in |
1222
|
|
|
|
|
|
|
L. |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
In scalar context it will return a reference to the array. |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
The C<$limit> and C<$offset> arguments are added by DBIx::OO and allow you |
1227
|
|
|
|
|
|
|
to limit/paginate your query. |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
UPDATE 0.0.7: |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
Certain queries are difficult to express in SQL::Abstract syntax. The |
1232
|
|
|
|
|
|
|
search accepts a literal WHERE clause too, but until version 0.0.7 |
1233
|
|
|
|
|
|
|
there was no way to specify bind variables. For example, now you can |
1234
|
|
|
|
|
|
|
do this: |
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
@admins = Users->search("mode & ? <> 0 and created > ?", |
1237
|
|
|
|
|
|
|
undef, undef, undef, |
1238
|
|
|
|
|
|
|
MODE_FLAGS->{admin}, |
1239
|
|
|
|
|
|
|
strftime('%Y-%m-%d', localtime)). |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
In order to pass bind variables, you must pass order, limit and offset |
1242
|
|
|
|
|
|
|
(give undef if you don't care about them) and add your bind variables |
1243
|
|
|
|
|
|
|
immediately after. |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
=cut |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
sub search { |
1248
|
0
|
|
|
0
|
1
|
|
my $class = __T(shift); |
1249
|
0
|
|
|
|
|
|
my ($where, $order, $limit, $offset) = @_; |
1250
|
0
|
|
|
|
|
|
splice @_, 0, 4; |
1251
|
0
|
|
|
|
|
|
my $sa = $class->get_sql_abstract; |
1252
|
0
|
|
|
|
|
|
my $cols = $class->_get_columns([ 'P', 'E' ]); |
1253
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->select($class->table, $cols, $where, $order, $limit, $offset); |
1254
|
0
|
0
|
|
|
|
|
if (@_) { |
1255
|
0
|
|
|
|
|
|
push @bind, @_; |
1256
|
|
|
|
|
|
|
} |
1257
|
0
|
|
|
|
|
|
my $sth = $class->_run_sql($sql, \@bind); |
1258
|
0
|
|
|
|
|
|
my @ret = (); |
1259
|
0
|
|
|
|
|
|
while (my $row = $sth->fetchrow_arrayref) { |
1260
|
0
|
|
|
|
|
|
my $obj = $class->new; |
1261
|
0
|
|
|
|
|
|
@{$obj->{values}}{@$cols} = @$row; |
|
0
|
|
|
|
|
|
|
1262
|
0
|
|
|
|
|
|
push @ret, $obj; |
1263
|
|
|
|
|
|
|
} |
1264
|
0
|
0
|
|
|
|
|
return wantarray ? @ret : \@ret; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
=head2 C |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
retrieve_all() is an alias to search() -- since with no arguments it |
1270
|
|
|
|
|
|
|
fetches all objects. |
1271
|
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
|
=cut |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
*retrieve_all = *search; |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
=head2 C |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
$u->set(first_name => 'Foo', |
1279
|
|
|
|
|
|
|
last_name => 'Bar'); |
1280
|
|
|
|
|
|
|
$u->update; |
1281
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
Saves any modified columns to the database. |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
=cut |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
sub update { |
1287
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
1288
|
0
|
0
|
|
|
|
|
if (ref $class) { |
1289
|
0
|
|
|
|
|
|
$class->_do_update; |
1290
|
|
|
|
|
|
|
} else { |
1291
|
0
|
|
|
|
|
|
my ($fieldvals, $where) = @_; |
1292
|
0
|
|
|
|
|
|
my $sa = $class->get_sql_abstract; |
1293
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->update($class->table, $fieldvals, $where); |
1294
|
0
|
|
|
|
|
|
$class->_run_sql($sql, \@bind); |
1295
|
|
|
|
|
|
|
} |
1296
|
|
|
|
|
|
|
} |
1297
|
|
|
|
|
|
|
|
1298
|
|
|
|
|
|
|
=head2 C |
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
$u = Users->retrieve('foo'); |
1301
|
|
|
|
|
|
|
$u->delete; |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
Removes the object's record from the database. Note that the Perl |
1304
|
|
|
|
|
|
|
object remains intact and you can actually revive it (if you're not |
1305
|
|
|
|
|
|
|
losing it) using undelete(). |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
=cut |
1308
|
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
|
sub delete { |
1310
|
0
|
|
|
0
|
1
|
|
my ($self, $where) = @_; |
1311
|
0
|
|
|
|
|
|
my ($sql, @bind); |
1312
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1313
|
0
|
0
|
|
|
|
|
if (!defined $where) { |
1314
|
|
|
|
|
|
|
# we're deleting one object |
1315
|
0
|
|
|
|
|
|
($sql, @bind) = $sa->delete($self->table, $self->_get_pk_where); |
1316
|
|
|
|
|
|
|
} else { |
1317
|
|
|
|
|
|
|
# deleting multiple objects at once |
1318
|
0
|
|
|
|
|
|
($sql, @bind) = $sa->delete($self->table, $where); |
1319
|
|
|
|
|
|
|
} |
1320
|
0
|
|
|
|
|
|
$self->_run_sql($sql, \@bind); |
1321
|
|
|
|
|
|
|
} |
1322
|
|
|
|
|
|
|
|
1323
|
|
|
|
|
|
|
=head2 C |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
$u = Users->retrieve('foo'); |
1326
|
|
|
|
|
|
|
$u->delete; # record's gone |
1327
|
|
|
|
|
|
|
$u->undelete; # resurrected |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
This function can "ressurect" an object that has been deleted (that |
1330
|
|
|
|
|
|
|
is, it re-INSERT-s the record into the database), provided that you |
1331
|
|
|
|
|
|
|
still have a reference to the object. I'm not sure how useful it is, |
1332
|
|
|
|
|
|
|
but it helped me test the delete() function. :-) |
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
Other (unuseful) thing you can do with it is manually emulating the |
1335
|
|
|
|
|
|
|
create() function: |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
$u = new Users; |
1338
|
|
|
|
|
|
|
$u->{values}{id} = 'foo'; |
1339
|
|
|
|
|
|
|
$u->first_name('Foo'); |
1340
|
|
|
|
|
|
|
$u->last_name('Bar'); |
1341
|
|
|
|
|
|
|
$u->undelete; |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
Note we can't call the column accessors, nor use set/get, before we |
1344
|
|
|
|
|
|
|
have a primary key. |
1345
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
This method is not too useful in itself, but it helps understanding |
1347
|
|
|
|
|
|
|
the internals of DBIx::OO. If you want to read more about this, see |
1348
|
|
|
|
|
|
|
L. |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
=cut |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
sub undelete { |
1353
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1354
|
0
|
|
|
|
|
|
$self->_apply_defaults; |
1355
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1356
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->insert($self->table, $self->{values}); |
1357
|
0
|
|
|
|
|
|
$self->_run_sql($sql, \@bind); |
1358
|
0
|
|
|
|
|
|
$self->{modified} = {}; |
1359
|
|
|
|
|
|
|
} |
1360
|
|
|
|
|
|
|
|
1361
|
|
|
|
|
|
|
=head2 C, or C |
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
$u = Users->retrieve('foo'); |
1364
|
|
|
|
|
|
|
$u->first_name(undef); |
1365
|
|
|
|
|
|
|
$u->revert; |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
Discards any changes to the object, reverting to the state in the |
1368
|
|
|
|
|
|
|
database. Note this doesn't SELECT new data, it just reverts to |
1369
|
|
|
|
|
|
|
values saved in the C hash. See L for more |
1370
|
|
|
|
|
|
|
info. |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
C is an alias to C. |
1373
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
=cut |
1375
|
|
|
|
|
|
|
|
1376
|
|
|
|
|
|
|
sub revert { |
1377
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
1378
|
|
|
|
|
|
|
# delete @{$self->{values}}{keys %{$self->{modified}}}; |
1379
|
0
|
|
|
|
|
|
my $m = $self->{modified}; |
1380
|
0
|
|
|
|
|
|
@{$self->{values}}{keys %$m} = values %$m; |
|
0
|
|
|
|
|
|
|
1381
|
0
|
|
|
|
|
|
$self->{modified} = {}; |
1382
|
|
|
|
|
|
|
} |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
*discard_changes = \&revert; |
1385
|
|
|
|
|
|
|
|
1386
|
|
|
|
|
|
|
=head2 get_sql_abstract |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
Returns the instance of SQL::Abstract::WithLimit (our custom |
1389
|
|
|
|
|
|
|
derivative) suitable for generating SQL. This is cached (will be |
1390
|
|
|
|
|
|
|
created only the first time get_sql_abstract is called). |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
=cut |
1393
|
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
|
sub get_sql_abstract { |
1395
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
1396
|
0
|
|
|
|
|
|
my $sa = $class->__dboo_sqlabstract; |
1397
|
0
|
0
|
|
|
|
|
if (!defined $sa) { |
1398
|
0
|
|
|
|
|
|
$sa = SQL::Abstract::WithLimit->new(quote_char => '`', # NOTE: MySQL quote style |
1399
|
|
|
|
|
|
|
name_sep => '.'); |
1400
|
0
|
|
|
|
|
|
$class->__dboo_sqlabstract($sa); |
1401
|
|
|
|
|
|
|
} |
1402
|
0
|
|
|
|
|
|
return $sa; |
1403
|
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
|
=head2 count |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
Returns the result of an SQL COUNT(*) for the specified where clause. |
1408
|
|
|
|
|
|
|
Call this as a package method, for example: |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
$number_of_romanians = Users->count({ country => 'RO' }); |
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
The argument is an SQL::Abstract where clause. |
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
=cut |
1415
|
|
|
|
|
|
|
|
1416
|
|
|
|
|
|
|
sub count { |
1417
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
1418
|
0
|
0
|
|
|
|
|
my $where = ref $_[0] eq 'HASH' ? $_[0] : { @_ }; |
1419
|
0
|
|
|
|
|
|
my $sql = 'SELECT COUNT(*) FROM ' . $class->table; |
1420
|
0
|
|
|
|
|
|
($where, my @bind) = $class->get_sql_abstract->where($where); |
1421
|
0
|
|
|
|
|
|
my $sth = $class->_run_sql($sql.$where, \@bind); |
1422
|
0
|
|
|
|
|
|
return $sth->fetchrow_arrayref->[0]; |
1423
|
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
sub _get_pk_where { |
1426
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
1427
|
0
|
|
|
|
|
|
my $pc = $self->columns('P'); |
1428
|
0
|
|
|
|
|
|
my %where = (); |
1429
|
0
|
|
|
|
|
|
@where{@$pc} = @{$self->{values}}{@$pc}; |
|
0
|
|
|
|
|
|
|
1430
|
0
|
|
|
|
|
|
return \%where; |
1431
|
|
|
|
|
|
|
} |
1432
|
|
|
|
|
|
|
|
1433
|
|
|
|
|
|
|
sub _run_sql { |
1434
|
0
|
|
|
0
|
|
|
my ($class, $sql, $bind) = @_; |
1435
|
|
|
|
|
|
|
# { |
1436
|
|
|
|
|
|
|
# ## DEBUG |
1437
|
|
|
|
|
|
|
# no warnings 'uninitialized'; |
1438
|
|
|
|
|
|
|
# my @a = map { defined $_ ? $_ : 'NULL' } @$bind; |
1439
|
|
|
|
|
|
|
# print STDERR "\033[1;33mSQL: $sql\nVAL: ", join(", ", @a), "\n\033[0m"; |
1440
|
|
|
|
|
|
|
# } |
1441
|
0
|
|
|
|
|
|
my $dbh = $class->get_dbh; |
1442
|
0
|
|
|
|
|
|
my $sth = $dbh->prepare($sql); |
1443
|
0
|
0
|
|
|
|
|
if ($bind) { |
1444
|
0
|
|
|
|
|
|
$sth->execute(@$bind); |
1445
|
|
|
|
|
|
|
} else { |
1446
|
0
|
|
|
|
|
|
$sth->execute(); |
1447
|
|
|
|
|
|
|
} |
1448
|
0
|
|
|
|
|
|
return $sth; |
1449
|
|
|
|
|
|
|
} |
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
sub _do_update { |
1452
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
1453
|
0
|
|
|
|
|
|
my %set = (); |
1454
|
0
|
|
|
|
|
|
my @k = keys %{$self->{modified}}; |
|
0
|
|
|
|
|
|
|
1455
|
0
|
0
|
|
|
|
|
if (@k) { |
1456
|
0
|
|
|
|
|
|
@set{@k} = @{$self->{values}}{@k}; |
|
0
|
|
|
|
|
|
|
1457
|
0
|
|
|
|
|
|
my $where = $self->_get_pk_where; |
1458
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1459
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->update($self->table, \%set, $where); |
1460
|
0
|
|
|
|
|
|
$self->_run_sql($sql, \@bind); |
1461
|
0
|
|
|
|
|
|
$self->{modified} = {}; |
1462
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %set) { |
1463
|
0
|
0
|
|
|
|
|
delete $self->{values}{$k} |
1464
|
|
|
|
|
|
|
if ref $v; |
1465
|
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
|
} |
1467
|
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
sub _get_columns { |
1470
|
0
|
|
|
0
|
|
|
my ($self, $groups, $exclude) = @_; |
1471
|
0
|
|
|
|
|
|
my $ek; |
1472
|
0
|
0
|
0
|
|
|
|
if (!$groups || @$groups == 0) { |
|
|
0
|
|
|
|
|
|
1473
|
0
|
|
|
|
|
|
$ek = $self->columns; |
1474
|
|
|
|
|
|
|
} elsif (@$groups == 1) { |
1475
|
0
|
|
|
|
|
|
$ek = $self->columns($groups->[0]); |
1476
|
|
|
|
|
|
|
} else { |
1477
|
0
|
|
|
|
|
|
$ek = []; |
1478
|
0
|
|
|
|
|
|
foreach my $g (@$groups) { |
1479
|
0
|
|
|
|
|
|
my $a = $self->columns($g); |
1480
|
0
|
0
|
|
|
|
|
push @$ek, @{$a} |
|
0
|
|
|
|
|
|
|
1481
|
|
|
|
|
|
|
if $a; |
1482
|
|
|
|
|
|
|
} |
1483
|
|
|
|
|
|
|
} |
1484
|
0
|
0
|
0
|
|
|
|
if (defined $exclude && %$exclude) { |
1485
|
0
|
|
|
|
|
|
$ek = [ grep { !exists $exclude->{$_} } @$ek ]; |
|
0
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
} |
1487
|
0
|
|
|
|
|
|
return $ek; |
1488
|
|
|
|
|
|
|
} |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
sub _retrieve_columns { |
1491
|
0
|
|
|
0
|
|
|
my ($self, $groups, $exclude) = @_; |
1492
|
0
|
0
|
|
|
|
|
if (!ref $groups) { |
1493
|
0
|
|
|
|
|
|
$groups = [ $groups ]; |
1494
|
|
|
|
|
|
|
} |
1495
|
0
|
|
0
|
|
|
|
my $ek = $self->_get_columns($groups, $exclude || $self->{modified}); |
1496
|
0
|
|
|
|
|
|
my $where = $self->_get_pk_where; |
1497
|
0
|
|
|
|
|
|
my $sa = $self->get_sql_abstract; |
1498
|
0
|
|
|
|
|
|
my ($sql, @bind) = $sa->select($self->table, $ek, $where); |
1499
|
0
|
|
|
|
|
|
my $sth = $self->_run_sql($sql, \@bind); |
1500
|
0
|
|
|
|
|
|
my $data = $sth->fetchrow_arrayref; |
1501
|
0
|
|
|
|
|
|
@{$self->{values}}{@$ek} = @$data; |
|
0
|
|
|
|
|
|
|
1502
|
|
|
|
|
|
|
} |
1503
|
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
|
sub _get_last_id { |
1505
|
0
|
|
|
0
|
|
|
my ($self, $dbh) = @_; |
1506
|
|
|
|
|
|
|
my $id = $dbh->last_insert_id(undef, undef, $self->table, undef) |
1507
|
|
|
|
|
|
|
|| $dbh->{mysql_insertid} |
1508
|
0
|
0
|
0
|
|
|
|
|| eval { $dbh->func('last_insert_rowid') } |
1509
|
|
|
|
|
|
|
or $self->_croak("Can't get last insert id"); |
1510
|
0
|
|
|
|
|
|
return $id; |
1511
|
|
|
|
|
|
|
} |
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
sub _col_in_group { |
1514
|
0
|
|
|
0
|
|
|
my ($class, $col, $group) = @_; |
1515
|
0
|
|
|
|
|
|
my $h = $class->__dboo_colgroups; |
1516
|
0
|
0
|
|
|
|
|
return if !$h; |
1517
|
0
|
|
|
|
|
|
return $h->{$col} eq $group; |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
sub _croak { |
1521
|
0
|
|
|
0
|
|
|
Carp::croak(join("\n", @_)); |
1522
|
|
|
|
|
|
|
} |
1523
|
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
|
sub _apply_defaults { |
1525
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
1526
|
0
|
|
|
|
|
|
my $class = __T($self); |
1527
|
0
|
|
|
|
|
|
my $def = $class->__dboo_defaults; |
1528
|
0
|
0
|
0
|
|
|
|
if ($def && %$def) { |
1529
|
0
|
|
|
|
|
|
my $val = $self->{values}; |
1530
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %$def) { |
1531
|
0
|
0
|
|
|
|
|
if (!exists $val->{$k}) { |
1532
|
0
|
0
|
|
|
|
|
if (ref $v eq 'CODE') { |
1533
|
0
|
|
|
|
|
|
$v = &$v(); |
1534
|
|
|
|
|
|
|
} |
1535
|
0
|
|
|
|
|
|
$val->{$k} = $v; |
1536
|
|
|
|
|
|
|
} |
1537
|
|
|
|
|
|
|
} |
1538
|
|
|
|
|
|
|
} |
1539
|
|
|
|
|
|
|
} |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
## thanks Altblue! |
1542
|
|
|
|
|
|
|
sub _to_utf8 { |
1543
|
0
|
|
|
0
|
|
|
my ($str) = @_; |
1544
|
0
|
0
|
|
|
|
|
return $str |
1545
|
|
|
|
|
|
|
if Encode::is_utf8($str); |
1546
|
0
|
|
|
|
|
|
eval { |
1547
|
0
|
|
|
|
|
|
$str = Encode::decode_utf8($str); |
1548
|
|
|
|
|
|
|
}; |
1549
|
0
|
0
|
|
|
|
|
if ($@) { |
1550
|
0
|
|
|
|
|
|
$str = Encode::decode('Detect', $str); |
1551
|
|
|
|
|
|
|
} |
1552
|
0
|
|
|
|
|
|
return $str; |
1553
|
|
|
|
|
|
|
} |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
=head2 C, C |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
Enable or disable foreign key checks in the backend DB server. These |
1558
|
|
|
|
|
|
|
are hard-coded in MySQL syntax for now so be careful not to use them |
1559
|
|
|
|
|
|
|
with other servers. ;-) |
1560
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
=cut |
1562
|
|
|
|
|
|
|
|
1563
|
|
|
|
|
|
|
sub disable_fk_checks { |
1564
|
0
|
|
|
0
|
1
|
|
my ($pak) = @_; |
1565
|
|
|
|
|
|
|
# XXX: MySQL only for now |
1566
|
0
|
|
|
|
|
|
$pak->get_dbh->do('set foreign_key_checks = 0'); |
1567
|
|
|
|
|
|
|
} |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
sub enable_fk_checks { |
1570
|
0
|
|
|
0
|
1
|
|
my ($pak) = @_; |
1571
|
|
|
|
|
|
|
# XXX: MySQL only for now |
1572
|
0
|
|
|
|
|
|
$pak->get_dbh->do('set foreign_key_checks = 1'); |
1573
|
|
|
|
|
|
|
} |
1574
|
|
|
|
|
|
|
|
1575
|
|
|
|
|
|
|
sub DESTROY { |
1576
|
0
|
|
|
0
|
|
|
my $self = shift; |
1577
|
0
|
|
|
|
|
|
my @a = keys %{$self->{modified}}; |
|
0
|
|
|
|
|
|
|
1578
|
0
|
0
|
|
|
|
|
if (@a) { |
1579
|
0
|
|
|
|
|
|
my @id = $self->id; |
1580
|
0
|
|
|
|
|
|
warn("Destroying ", ref $self, " with ID: ", join(':', @id), ' having uncomitted data: ', join(':', @a)); |
1581
|
|
|
|
|
|
|
} |
1582
|
|
|
|
|
|
|
} |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
## database autocreate/update facility |
1585
|
|
|
|
|
|
|
|
1586
|
|
|
|
|
|
|
=head2 C |
1587
|
|
|
|
|
|
|
|
1588
|
|
|
|
|
|
|
You can use this facility to automatically create / upgrade your |
1589
|
|
|
|
|
|
|
database. It takes a very simple (rudimentary even) approach, but we |
1590
|
|
|
|
|
|
|
found it to be useful. Here's the "big" idea. |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
package MyDB::Users; |
1593
|
|
|
|
|
|
|
use base 'MyDB'; |
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
__PACKAGE__->table('Users'); |
1596
|
|
|
|
|
|
|
__PACKAGE__->columns(P => [ 'id' ], |
1597
|
|
|
|
|
|
|
E => [qw/ first_name last_name /]); |
1598
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
sub get_autocreate_data {q{ |
1601
|
|
|
|
|
|
|
#### (users:0) #### |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
CREATE TABLE Users ( id VARCHAR(32) NOT NULL PRIMARY KEY, |
1604
|
|
|
|
|
|
|
first_name VARCHAR(64), |
1605
|
|
|
|
|
|
|
last_name VARCHAR(64) ); |
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
# you can put Perl comments too. |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
CREATE INDEX idx_Users_first_name ON Users(first_name) |
1610
|
|
|
|
|
|
|
}} |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
OK, now you can write this make_database.pl script: |
1613
|
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
|
/usr/bin/perl -w |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
use MyDB; |
1617
|
|
|
|
|
|
|
MyDB->autocreate(qw( MyDB::Users )); |
1618
|
|
|
|
|
|
|
|
1619
|
|
|
|
|
|
|
When you run this script the first time, it will create the Users |
1620
|
|
|
|
|
|
|
table. (An internal _dbix_oo_versions table gets created as well; |
1621
|
|
|
|
|
|
|
we're using it inside DBIx::OO in order to keep track of existing |
1622
|
|
|
|
|
|
|
table versions). Note that if you run it again, it doesn't do |
1623
|
|
|
|
|
|
|
anything--the database is up to date. |
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
Later. You sold a billion copies of your software, customers are |
1626
|
|
|
|
|
|
|
happy but they are crying loud for an "email" field in their user |
1627
|
|
|
|
|
|
|
profiles, also wondering what was your idea to index on first_name and |
1628
|
|
|
|
|
|
|
not on last_name! In order to make it easy for them to upgrade their |
1629
|
|
|
|
|
|
|
databases, you need to modify MyDB::Users. Besides declaring the |
1630
|
|
|
|
|
|
|
'email' column using __PACKAGE__->columns, B the following to |
1631
|
|
|
|
|
|
|
your get_autocreate_data section: |
1632
|
|
|
|
|
|
|
|
1633
|
|
|
|
|
|
|
#### (users:1) #### |
1634
|
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
|
# (note that we incremented the version number) |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
# add the 'email' field |
1638
|
|
|
|
|
|
|
ALTER TABLE Users ADD (email VARCHAR(128)); |
1639
|
|
|
|
|
|
|
|
1640
|
|
|
|
|
|
|
# index it |
1641
|
|
|
|
|
|
|
CREATE UNIQUE INDEX idx_Users_email ON Users(email); |
1642
|
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
|
# and add that last_name index |
1644
|
|
|
|
|
|
|
CREATE INDEX idx_Users_last_name ON Users(last_name); |
1645
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
Now you can just tell your users to run make_database.pl again and |
1647
|
|
|
|
|
|
|
everything gets updated. |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
The #### (foo:N) #### syntax is meant simply to declare an ID and a |
1650
|
|
|
|
|
|
|
version number. "foo" can be anything you want -- it doesn't have to |
1651
|
|
|
|
|
|
|
be the table name. You can actually create multiple tables, if you |
1652
|
|
|
|
|
|
|
need to. |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
=cut |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
sub autocreate { |
1657
|
0
|
|
|
0
|
1
|
|
my ($class, @packages) = @_; |
1658
|
0
|
|
|
|
|
|
$class->disable_fk_checks; |
1659
|
0
|
|
|
|
|
|
$class->transaction_start; |
1660
|
0
|
|
|
|
|
|
eval { |
1661
|
2
|
|
|
2
|
|
230262
|
use Module::Load qw( load ); |
|
2
|
|
|
|
|
2904
|
|
|
2
|
|
|
|
|
12
|
|
1662
|
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
|
# make sure _dbix_oo_versions gets created first |
1664
|
0
|
|
|
|
|
|
my @sql_lines = split(/^/m, get_autocreate_data()); |
1665
|
0
|
|
|
|
|
|
$class->__do_autocreate(@sql_lines); |
1666
|
|
|
|
|
|
|
|
1667
|
|
|
|
|
|
|
# autocreate other packages that were passed |
1668
|
0
|
|
|
|
|
|
foreach my $pak (@packages) { |
1669
|
0
|
|
|
|
|
|
load $pak; |
1670
|
0
|
|
|
|
|
|
@sql_lines = split(/^/m, $pak->get_autocreate_data()); |
1671
|
0
|
|
|
|
|
|
$class->__do_autocreate(@sql_lines); |
1672
|
|
|
|
|
|
|
} |
1673
|
|
|
|
|
|
|
}; |
1674
|
0
|
0
|
|
|
|
|
if ($@) { |
1675
|
0
|
|
|
|
|
|
$class->transaction_rollback; |
1676
|
0
|
|
|
|
|
|
print STDERR "\033[1;31m- There was a problem auto-creating or upgrading tables, can't continue -\033[0m\n"; |
1677
|
0
|
|
|
|
|
|
die $@; |
1678
|
|
|
|
|
|
|
} else { |
1679
|
0
|
|
|
|
|
|
$class->transaction_commit; |
1680
|
|
|
|
|
|
|
} |
1681
|
0
|
|
|
|
|
|
foreach my $pak (@packages) { |
1682
|
0
|
|
|
|
|
|
$pak->autopopulate; |
1683
|
|
|
|
|
|
|
} |
1684
|
0
|
|
|
|
|
|
$class->enable_fk_checks; |
1685
|
|
|
|
|
|
|
} |
1686
|
|
|
|
|
|
|
|
1687
|
|
|
|
|
|
|
=head2 autopopulate |
1688
|
|
|
|
|
|
|
|
1689
|
|
|
|
|
|
|
This is supposed to initialize tables. Untested and may not work -- |
1690
|
|
|
|
|
|
|
don't use it. |
1691
|
|
|
|
|
|
|
|
1692
|
|
|
|
|
|
|
=cut |
1693
|
|
|
|
|
|
|
|
1694
|
0
|
|
|
0
|
1
|
|
sub autopopulate {} |
1695
|
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
=head2 get_autocreate_data |
1697
|
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
|
See the documentation of L. |
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
=cut |
1701
|
|
|
|
|
|
|
|
1702
|
0
|
|
|
0
|
1
|
|
sub get_autocreate_data {q{ |
1703
|
|
|
|
|
|
|
#### (_dbix_oo_versions:0) #### |
1704
|
|
|
|
|
|
|
|
1705
|
|
|
|
|
|
|
CREATE TABLE _dbix_oo_versions ( TB_name VARCHAR(255) PRIMARY KEY, |
1706
|
|
|
|
|
|
|
TB_version INTEGER ); |
1707
|
|
|
|
|
|
|
}} |
1708
|
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
|
my $AUTOCREATE_LINE_RE = qr/^\s*####\s*\(([a-z0-9_-]+):([0-9]+)\)\s*####\s*$/i; |
1710
|
|
|
|
|
|
|
# my $AUTOCREATE_SPLIT_SQLS = qr/^\s*##\s*$/m; |
1711
|
|
|
|
|
|
|
my $AUTOCREATE_SPLIT_SQLS = qr/;\s*$/m; |
1712
|
|
|
|
|
|
|
my $AUTOCREATE_TABLES_TABLE = '_dbix_oo_versions'; |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
sub __do_autocreate { |
1715
|
0
|
|
|
0
|
|
|
my ($class, @lines) = @_; |
1716
|
|
|
|
|
|
|
|
1717
|
0
|
|
|
|
|
|
my $tables = $class->__autocreate_parse_lines(\@lines); |
1718
|
|
|
|
|
|
|
|
1719
|
0
|
|
|
|
|
|
my $dbh = $class->get_dbh; |
1720
|
0
|
|
|
|
|
|
my $sth = $dbh->table_info('', '', $AUTOCREATE_TABLES_TABLE); |
1721
|
0
|
|
|
|
|
|
my $existing_tables = $sth->fetchall_hashref('TABLE_NAME'); |
1722
|
0
|
|
|
|
|
|
my $has_version = exists $existing_tables->{$AUTOCREATE_TABLES_TABLE}; |
1723
|
0
|
|
|
|
|
|
$sth->finish; |
1724
|
|
|
|
|
|
|
|
1725
|
0
|
|
|
|
|
|
while (my ($t, $versions) = each %$tables) { |
1726
|
0
|
|
|
|
|
|
$class->__autocreate_one_table($t, $versions, $has_version); |
1727
|
|
|
|
|
|
|
} |
1728
|
|
|
|
|
|
|
} |
1729
|
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
|
sub __autocreate_one_table { |
1731
|
0
|
|
|
0
|
|
|
my ($class, $t, $versions, $has_version) = @_; |
1732
|
0
|
|
|
|
|
|
my $dbh = $class->get_dbh; |
1733
|
0
|
|
|
|
|
|
my $cv = -1; |
1734
|
0
|
0
|
|
|
|
|
if ($has_version) { |
1735
|
0
|
|
|
|
|
|
my $sql = $dbh->prepare("SELECT TB_version FROM $AUTOCREATE_TABLES_TABLE WHERE TB_name = ?"); |
1736
|
0
|
|
|
|
|
|
$sql->execute($t); |
1737
|
0
|
|
|
|
|
|
($cv) = $sql->fetchrow_array; |
1738
|
0
|
|
|
|
|
|
$sql->finish; |
1739
|
0
|
0
|
|
|
|
|
if (!defined $cv) { |
1740
|
0
|
|
|
|
|
|
$cv = -1; |
1741
|
0
|
|
|
|
|
|
$sql = $dbh->prepare("INSERT INTO $AUTOCREATE_TABLES_TABLE (TB_name, TB_version) VALUES (?, ?)"); |
1742
|
0
|
|
|
|
|
|
$sql->execute($t, $cv); |
1743
|
0
|
|
|
|
|
|
$sql->finish; |
1744
|
|
|
|
|
|
|
} |
1745
|
|
|
|
|
|
|
} |
1746
|
0
|
|
|
|
|
|
my $sql_insert = $dbh->prepare("INSERT INTO $AUTOCREATE_TABLES_TABLE (TB_name, TB_version) VALUES (?, ?)"); |
1747
|
0
|
|
|
|
|
|
my $sql_delete = $dbh->prepare("DELETE FROM $AUTOCREATE_TABLES_TABLE WHERE TB_name = ?"); |
1748
|
0
|
|
|
|
|
|
foreach my $v (sort keys %$versions) { |
1749
|
0
|
0
|
|
|
|
|
if ($v > $cv) { |
1750
|
|
|
|
|
|
|
# print STDERR "$versions->{$v}\n"; |
1751
|
0
|
|
|
|
|
|
my @statements = split($AUTOCREATE_SPLIT_SQLS, $versions->{$v}); |
1752
|
0
|
|
|
|
|
|
foreach my $sql (@statements) { |
1753
|
0
|
|
|
|
|
|
$sql =~ s/#.*$//mg; |
1754
|
0
|
|
|
|
|
|
$sql =~ s/^\s+//; |
1755
|
0
|
|
|
|
|
|
$sql =~ s/\s+$//; |
1756
|
0
|
|
|
|
|
|
$sql =~ s/,\s*\)/)/g; |
1757
|
0
|
0
|
|
|
|
|
if ($sql) { |
1758
|
|
|
|
|
|
|
# print STDERR " $sql\n"; |
1759
|
0
|
|
|
|
|
|
my $n = index($sql, "\n"); |
1760
|
0
|
|
|
|
|
|
print STDERR "... $t: " . substr($sql, 0, $n) . "\n"; |
1761
|
0
|
|
|
|
|
|
$dbh->do($sql); |
1762
|
|
|
|
|
|
|
} |
1763
|
|
|
|
|
|
|
} |
1764
|
0
|
|
|
|
|
|
$sql_delete->execute($t); |
1765
|
0
|
|
|
|
|
|
$sql_insert->execute($t, $v); |
1766
|
|
|
|
|
|
|
} |
1767
|
|
|
|
|
|
|
} |
1768
|
0
|
|
|
|
|
|
$sql_insert->finish; |
1769
|
0
|
|
|
|
|
|
$sql_delete->finish; |
1770
|
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
sub __autocreate_parse_lines { |
1773
|
0
|
|
|
0
|
|
|
my ($class, $lines) = @_; |
1774
|
0
|
|
|
|
|
|
my ($h, $ct, $cv, $cs) = ({}, undef, undef, undef); |
1775
|
|
|
|
|
|
|
my $doit = sub { |
1776
|
0
|
0
|
|
0
|
|
|
if (defined $ct) { |
1777
|
0
|
|
0
|
|
|
|
$h->{$ct} ||= {}; |
1778
|
0
|
|
|
|
|
|
$cs =~ s/^\s+//; |
1779
|
0
|
|
|
|
|
|
$cs =~ s/\s+$//; |
1780
|
0
|
|
|
|
|
|
$h->{$ct}{$cv} = $cs; |
1781
|
|
|
|
|
|
|
} |
1782
|
0
|
|
|
|
|
|
}; |
1783
|
0
|
|
|
|
|
|
foreach my $i (@$lines) { |
1784
|
0
|
0
|
|
|
|
|
if ($i =~ $AUTOCREATE_LINE_RE) { |
|
|
0
|
|
|
|
|
|
1785
|
0
|
|
|
|
|
|
&$doit; |
1786
|
0
|
|
|
|
|
|
$ct = $1; |
1787
|
0
|
|
|
|
|
|
$cv = $2; |
1788
|
0
|
|
|
|
|
|
$cs = ''; |
1789
|
|
|
|
|
|
|
} elsif (defined $ct) { |
1790
|
0
|
|
|
|
|
|
$cs .= $i; |
1791
|
|
|
|
|
|
|
} |
1792
|
|
|
|
|
|
|
} |
1793
|
0
|
|
|
|
|
|
&$doit; |
1794
|
|
|
|
|
|
|
# print STDERR Data::Dumper::Dumper($h); |
1795
|
0
|
|
|
|
|
|
return $h; |
1796
|
|
|
|
|
|
|
} |
1797
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
=head1 CAVEATS |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
There are a number of problems you might encounter, mostly related to |
1801
|
|
|
|
|
|
|
the fact that we don't cache objects. |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
=head2 Concurrent objects |
1804
|
|
|
|
|
|
|
|
1805
|
|
|
|
|
|
|
$u1 = Users->retrieve('foo'); |
1806
|
|
|
|
|
|
|
$u2 = Users->retrieve('foo'); |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
C<$u1> and C<$u2> now point to different objects, but both point to |
1809
|
|
|
|
|
|
|
the same record in the database. Now the problem: |
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
$u1->first_name('Foo'); |
1812
|
|
|
|
|
|
|
$u2->first_name('Bar'); |
1813
|
|
|
|
|
|
|
$u1->update; |
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
Which one gets set? 'Foo', but $u2 has uncommitted changes. When you |
1816
|
|
|
|
|
|
|
further say $u2->update, it will set the name to 'Bar'. If you say |
1817
|
|
|
|
|
|
|
$u2->revert, it will revert to whatever was there I 'Foo'. |
1818
|
|
|
|
|
|
|
This can lead to potential problems. |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
Class::DBI (almost) doesn't have this problem (it can appear when you |
1821
|
|
|
|
|
|
|
have multiple processes accessing the database concurrently, such as |
1822
|
|
|
|
|
|
|
httpd processes). |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
=head1 UNDER THE HOOD |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
A DBIx::OO object is a hash blessed into the DBIx::OO package. |
1827
|
|
|
|
|
|
|
The hash currently contains 2 keys: |
1828
|
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
=over |
1830
|
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
|
=item B |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
A hash containing the field => value pairs that are currently |
1834
|
|
|
|
|
|
|
retrieved from the database. |
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
=item B |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
Another hash that maps field_name => 'original value' for the fields |
1839
|
|
|
|
|
|
|
that were modified and not yet committed of the current object. |
1840
|
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
|
=back |
1842
|
|
|
|
|
|
|
|
1843
|
|
|
|
|
|
|
If a field is not present in B and is requested with get(), |
1844
|
|
|
|
|
|
|
then the database will be queried for it and for all other fields that |
1845
|
|
|
|
|
|
|
aren't present in "values" but are listed in the Bssential group. |
1846
|
|
|
|
|
|
|
|
1847
|
|
|
|
|
|
|
If a field is present in B, then it will be saved in the DB |
1848
|
|
|
|
|
|
|
on the next update() call. An object can discard these operations |
1849
|
|
|
|
|
|
|
with the discard() method. Discard restores the values using those |
1850
|
|
|
|
|
|
|
stored in the C hash. |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
Each operation plays around these hashes. For instance, when you call |
1853
|
|
|
|
|
|
|
search(), a single SQL will run and then we'll iterate over the |
1854
|
|
|
|
|
|
|
results, create objects and assign the SELECT-ed values to the |
1855
|
|
|
|
|
|
|
B hash. |
1856
|
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
|
A retrieve() operation creates a new object and assign the passed |
1858
|
|
|
|
|
|
|
value to its primary key, then it will call the internal |
1859
|
|
|
|
|
|
|
_retrieve_columns([ 'P', 'E' ]) function in order to fetch essential |
1860
|
|
|
|
|
|
|
object data from the DB. Note that a call to _retrieve_columns is not |
1861
|
|
|
|
|
|
|
actually necessary, since it will happen anyway the first time you |
1862
|
|
|
|
|
|
|
want to retrieve a field that doesn't exist in B -- but it's |
1863
|
|
|
|
|
|
|
good to call it because retrieve() should return B if the |
1864
|
|
|
|
|
|
|
object can't be found in the DB. |
1865
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
=head1 BUGS |
1867
|
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
|
Yeah, the documentation sucks. Other bugs? |
1869
|
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
|
=head1 SEE ALSO |
1871
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
L, L, L |
1873
|
|
|
|
|
|
|
|
1874
|
|
|
|
|
|
|
=head1 AUTHOR |
1875
|
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
|
Mihai Bazon, |
1877
|
|
|
|
|
|
|
http://www.dynarch.com/ |
1878
|
|
|
|
|
|
|
http://www.bazon.net/mishoo/ |
1879
|
|
|
|
|
|
|
|
1880
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
Copyright (c) Mihai Bazon 2006. All rights reserved. |
1883
|
|
|
|
|
|
|
|
1884
|
|
|
|
|
|
|
This module is free software; you can redistribute it and/or modify it |
1885
|
|
|
|
|
|
|
under the same terms as Perl itself. |
1886
|
|
|
|
|
|
|
|
1887
|
|
|
|
|
|
|
=head1 THANKS |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
I'd like to thank irc.n0i.net -- our small but wonderful community |
1890
|
|
|
|
|
|
|
that's always there when you need it. |
1891
|
|
|
|
|
|
|
|
1892
|
|
|
|
|
|
|
=head1 DISCLAIMER OF WARRANTY |
1893
|
|
|
|
|
|
|
|
1894
|
|
|
|
|
|
|
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY |
1895
|
|
|
|
|
|
|
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT |
1896
|
|
|
|
|
|
|
WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER |
1897
|
|
|
|
|
|
|
PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, |
1898
|
|
|
|
|
|
|
EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE |
1899
|
|
|
|
|
|
|
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
1900
|
|
|
|
|
|
|
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE |
1901
|
|
|
|
|
|
|
SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME |
1902
|
|
|
|
|
|
|
THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. |
1903
|
|
|
|
|
|
|
|
1904
|
|
|
|
|
|
|
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING |
1905
|
|
|
|
|
|
|
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR |
1906
|
|
|
|
|
|
|
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE |
1907
|
|
|
|
|
|
|
TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR |
1908
|
|
|
|
|
|
|
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE |
1909
|
|
|
|
|
|
|
SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING |
1910
|
|
|
|
|
|
|
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A |
1911
|
|
|
|
|
|
|
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF |
1912
|
|
|
|
|
|
|
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH |
1913
|
|
|
|
|
|
|
DAMAGES. |
1914
|
|
|
|
|
|
|
|
1915
|
|
|
|
|
|
|
=cut |
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
|
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
|
1920
|
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
|
|
1922
|
|
|
|
|
|
|
|
1923
|
|
|
|
|
|
|
package SQL::Abstract::WithLimit; |
1924
|
2
|
|
|
2
|
|
2564
|
use base 'SQL::Abstract'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
1066
|
|
1925
|
|
|
|
|
|
|
|
1926
|
|
|
|
|
|
|
### MySQL and Postgres syntax; Buzz off for others. :-p |
1927
|
|
|
|
|
|
|
sub select { |
1928
|
0
|
|
|
0
|
|
|
my ($self, $table, $cols, $where, $order, $limit, $offset) = @_; |
1929
|
0
|
|
|
|
|
|
my ($sql, @bind) = $self->SUPER::select($table, $cols, $where, $order); |
1930
|
0
|
|
|
|
|
|
$sql .= $self->order_and_limit(undef, $limit, $offset); |
1931
|
0
|
0
|
|
|
|
|
return wantarray ? ($sql, @bind) : $sql; |
1932
|
|
|
|
|
|
|
} |
1933
|
|
|
|
|
|
|
|
1934
|
|
|
|
|
|
|
sub _order_by { |
1935
|
0
|
|
|
0
|
|
|
my $self = shift; |
1936
|
0
|
|
|
|
|
|
my $ref = ref $_[0]; |
1937
|
|
|
|
|
|
|
|
1938
|
0
|
|
|
|
|
|
my @vals = $ref eq 'ARRAY' ? @{$_[0]} : |
|
0
|
|
|
|
|
|
|
1939
|
0
|
0
|
|
|
|
|
$ref eq 'SCALAR' ? ${$_[0]} : |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1940
|
|
|
|
|
|
|
$ref eq '' ? $_[0] : |
1941
|
|
|
|
|
|
|
SQL::Abstract::puke("Unsupported data struct $ref for ORDER BY"); |
1942
|
|
|
|
|
|
|
|
1943
|
0
|
0
|
|
|
|
|
my $val = join ', ', map { |
1944
|
0
|
|
|
|
|
|
s/^\^// ? |
1945
|
|
|
|
|
|
|
$self->_quote($_) . $self->_sqlcase(' desc') |
1946
|
|
|
|
|
|
|
: $self->_quote($_) |
1947
|
|
|
|
|
|
|
} @vals; |
1948
|
0
|
0
|
|
|
|
|
return $val ? $self->_sqlcase(' order by')." $val" : ''; |
1949
|
|
|
|
|
|
|
} |
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
sub order_and_limit { |
1952
|
0
|
|
|
0
|
|
|
my ($self, $order, $limit, $offset) = @_; |
1953
|
0
|
0
|
|
|
|
|
my $q = $order ? $self->_order_by($order) : ''; |
1954
|
0
|
0
|
|
|
|
|
$q .= " LIMIT $limit" |
1955
|
|
|
|
|
|
|
if defined $limit; |
1956
|
0
|
0
|
|
|
|
|
$q .= " OFFSET $offset" |
1957
|
|
|
|
|
|
|
if defined $offset; |
1958
|
0
|
|
|
|
|
|
return $q; |
1959
|
|
|
|
|
|
|
} |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
*quote_field = \&SQL::Abstract::_quote; |