make the searchindex table myisam, it has no use for ACID
[bse.git] / site / cgi-bin / modules / BSE / TB / TagOwner.pm
1 # mix-in (or close) for classes that keep tags
2 # currently just articles
3 # the owner class should implement a tag_owner_type method
4 package BSE::TB::TagOwner;
5 use strict;
6 use BSE::TB::Tags;
7 use BSE::TB::TagMembers;
8
9 our $VERSION = "1.004";
10
11 =head1 NAME
12
13 BSE::TB::TagOwner - mixin for objects with tags
14
15 =head1 SYNOPSIS
16
17   my $article = ...;
18
19   $article->set_tags([ qw/tag1 tag2/ ], \$error);
20   $article->remove_tags;
21
22   my @tags = $article->tag_objects;
23   my @tag_names = $article->tags;
24   my @tag_ids = $article->tag_ids;
25
26   if ($article->has_tags([ "tag1", "tag2" ])) {
27     ...
28   }
29
30 =head1 DESCRIPTION
31
32 This class is a mix-in that implements tags for the mixed-into object.
33
34 =head1 METHODS PROVIDED
35
36 =over
37
38 =item set_tags(\@tags, \$error)
39
40 Set the specified tags on the object, replacing all existing tags.
41
42 =cut
43
44 sub set_tags {
45   my ($self, $rtags, $rerror) = @_;
46
47   my @current_tags = $self->tag_objects;
48   my %current = map { $_->canon_name => $_ } @current_tags;
49   my %remove = %current;
50   my %save;
51   my %add;
52   for my $name (@$rtags) {
53     my $work = BSE::TB::Tags->name($name, $rerror);
54     defined $work or return;
55
56     my $lower = lc $work;
57     if ($current{$lower}) {
58       delete $remove{$lower};
59       if (!$save{$lower} && $name ne $current{$lower}->name) {
60         $save{$lower} = $name;
61       }
62     }
63     else {
64       $add{$lower} = $name;
65     }
66   }
67
68   for my $add (values %add) {
69     # look for or make the tag
70     my $tag = BSE::TB::Tags->getByName($self->tag_owner_type, $add);
71     if ($tag) {
72       if ($tag->name ne $add && !$save{lc $add}) {
73         $current{lc $add} = $tag;
74         $save{lc $add} = $add;
75       }
76     }
77     else {
78       $tag = BSE::TB::Tags->make_with_name($self->tag_owner_type, $add);
79     }
80
81     # add the reference
82     BSE::TB::TagMembers->make
83         (
84          owner_type => $self->tag_owner_type,
85          owner_id => $self->id,
86          tag_id => $tag->id,
87         );
88   }
89
90   for my $save (keys %save) {
91     my $new_name = $save{$save};
92     my $tag = $current{$save};
93     $tag->set_name($new_name);
94     $tag->save;
95   }
96
97   # remove any leftovers
98   for my $remove (values %remove) {
99     BSE::TB::TagMembers->remove_by_tag($self, $remove);
100   }
101
102   return 1;
103 }
104
105 =item remove_tags
106
107 Remove all tags from the object.
108
109 =cut
110
111 sub remove_tags {
112   my ($self) = @_;
113
114   BSE::TB::TagMembers->remove_owned_by($self);
115 }
116
117 =item tag_objects
118
119 Return all existing tags on the object as tag objects.
120
121 =cut
122
123 sub tag_objects {
124   my ($self) = @_;
125
126   return BSE::TB::Tags->getSpecial(object_tags => $self->tag_owner_type, $self->id);
127 }
128
129 =item tags
130
131 Returns all existing tags on the object as tag names.
132
133 =cut
134
135 sub tags {
136   my ($self) = @_;
137
138   return map $_->name, $self->tag_objects;
139 }
140
141 =item tag_ids
142
143 Returns all existing tags on the object as tag ids.
144
145 =cut
146
147 sub tag_ids {
148   my ($self) = @_;
149
150   return map $_->{id}, BSE::DB->single->query("Tag_ids.by_owner", $self->tag_owner_type, $self->id);
151 }
152
153 =item tag_members
154
155 Return all tag membership links for the object.
156
157 =cut
158
159 sub tag_members {
160   my ($self) = @_;
161
162   require BSE::TB::TagMembers;
163   return BSE::TB::TagMembers->getBy
164     (
165      owner_id => $self->id,
166      owner_type => $self->tag_owner_type,
167     );
168 }
169
170 =item has_tags(\@tags)
171
172 Check that all of the specified tags are on the object.
173
174 =cut
175
176 sub has_tags {
177   my ($self, $rtags) = @_;
178
179   my %my_tag_ids = map { $_ => 1 } $self->tag_ids;
180
181   # make sure we have objects, if there's no tag, we don't have that
182   # tage and can immediately return false
183   for my $tag (@$rtags) {
184     my $work = $tag;
185     unless (ref $work) {
186       $work = BSE::TB::Tags->getByName($self->tag_owner_type, $tag)
187         or return;
188     }
189
190     $my_tag_ids{$tag->id}
191       or return;
192   }
193
194   return 1;
195 }
196
197 =item tag_by_name
198
199 Return the tag (if any) by name for this object type.
200
201 Returns an empty list if no such tag is found.
202
203 =cut
204
205 sub tag_by_name {
206   my ($self, $name) = @_;
207
208   my ($tag) = BSE::TB::Tags->getByName($self->tag_owner_type, $name)
209     or return;
210
211   return $tag;
212 }
213
214 =item collection_with_tags()
215
216 This is a wrapper for L<BSE::TB::TagOwners/collection_with_tags()>
217 that passes $self as the C<self> parameter in \%opts.
218
219 =cut
220
221 sub collection_with_tags {
222   my ($self, $name, $tags, $opts) = @_;
223
224   return $self->tableClass->collection_with_tags
225     (
226      $name,
227      $tags,
228      {
229       ($opts ? %$opts : ()),
230       self => $self,
231      },
232     );
233 }
234
235 1;
236
237 __END__
238
239 =back
240
241 =head1 REQUIRED METHODS
242
243 These need to be implemented by the class that wants tags.
244
245 =over
246
247 =item tag_owner_type
248
249 Return a short constant string identifying owner class of the tags.
250
251 =item id
252
253 The numeric id of the specific owner object of the tags.
254
255 =item tableClass
256
257 The name of the class for collections of the tag owner.
258
259 =back
260
261 =head1 AUTHOR
262
263 Tony Cook <tony@develop-help.com>
264
265 =cut
266