Upgrade-Doku: Hinweis auf benötigtes Perl-Modul IPC::Run
[kivitendo-erp.git] / SL / DB / Helper / ActsAsList.pm
1 package SL::DB::Helper::ActsAsList;
2
3 use strict;
4
5 use parent qw(Exporter);
6 our @EXPORT = qw(move_position_up move_position_down add_to_list remove_from_list reorder_list configure_acts_as_list
7                  get_previous_in_list get_next_in_list get_full_list);
8
9 use Carp;
10 use SL::X;
11
12 my %list_spec;
13
14 sub import {
15   my ($class, @params)   = @_;
16   my $importing = caller();
17
18   configure_acts_as_list($importing, @params);
19
20   $importing->before_save(  sub { SL::DB::Helper::ActsAsList::set_position(@_)    });
21   $importing->before_delete(sub { SL::DB::Helper::ActsAsList::remove_position(@_) });
22
23   # Don't 'goto' to Exporters import, it would try to parse @params
24   __PACKAGE__->export_to_level(1, $class, @EXPORT);
25 }
26
27 #
28 # Exported functions
29 #
30
31 sub move_position_up {
32   my ($self) = @_;
33   do_move($self, 'up');
34 }
35
36 sub move_position_down {
37   my ($self) = @_;
38   do_move($self, 'down');
39 }
40
41 sub remove_from_list {
42   my ($self) = @_;
43
44   return $self->db->with_transaction(sub {
45     remove_position($self);
46
47     # Set to -1 manually because $self->update_attributes() would
48     # trigger the before_save() hook from this very plugin assigning a
49     # number at the end of the list again.
50     my $table           = $self->meta->table;
51     my $column          = column_name($self);
52     my $primary_key_col = ($self->meta->primary_key)[0];
53     my $sql             = <<SQL;
54       UPDATE ${table}
55       SET ${column} = -1
56       WHERE ${primary_key_col} = ?
57 SQL
58     $self->db->dbh->do($sql, undef, $self->$primary_key_col);
59     $self->$column(undef);
60   });
61 }
62
63 sub add_to_list {
64   my ($self, %params) = @_;
65
66   croak "Invalid parameter 'position'" unless ($params{position} || '') =~ m/^ (?: before | after | first | last ) $/x;
67
68   my $column = column_name($self);
69
70   $self->remove_from_list if ($self->$column // -1) != -1;
71
72   if ($params{position} eq 'last') {
73     set_position($self);
74     $self->save;
75     return;
76   }
77
78   my $table               = $self->meta->table;
79   my $primary_key_col     = ($self->meta->primary_key)[0];
80   my ($group_by, @values) = get_group_by_where($self);
81   $group_by               = " AND ${group_by}" if $group_by;
82   my $new_position;
83
84   if ($params{position} eq 'first') {
85     $new_position = 1;
86
87   } else {
88     # Can only be 'before' or 'after' -- 'last' has been checked above
89     # already.
90
91     my $reference = $params{reference};
92     croak "Missing parameter 'reference'" if !$reference;
93
94     my $reference_pos;
95     if (ref $reference) {
96       $reference_pos = $reference->$column;
97     } else {
98       ($reference_pos) = $self->db->dbh->selectrow_array(qq|SELECT ${column} FROM ${table} WHERE ${primary_key_col} = ?|, undef, $reference);
99     }
100
101     $new_position = $params{position} eq 'before' ? $reference_pos : $reference_pos + 1;
102   }
103
104   my $query = <<SQL;
105     UPDATE ${table}
106     SET ${column} = ${column} + 1
107     WHERE (${column} > ?)
108       ${group_by}
109 SQL
110
111   return $self->db->with_transaction(sub {
112     $self->db->dbh->do($query, undef, $new_position - 1, @values);
113     $self->update_attributes($column => $new_position);
114   });
115 }
116
117 sub get_next_in_list {
118   my ($self) = @_;
119   return get_previous_or_next($self, 'next');
120 }
121
122 sub get_previous_in_list {
123   my ($self) = @_;
124   return get_previous_or_next($self, 'previous');
125 }
126
127 sub get_full_list {
128   my ($self) = @_;
129
130   my $group_by = get_spec(ref $self, 'group_by') || [];
131   $group_by    = [ $group_by ] if $group_by && !ref $group_by;
132   my @where    = map { ($_ => $self->$_) } @{ $group_by };
133
134   return $self->_get_manager_class->get_all(where => \@where, sort_by => column_name($self) . ' ASC');
135 }
136
137 sub reorder_list {
138   my ($class_or_self, @ids) = @_;
139
140   return 1 unless @ids;
141
142   my $self   = ref($class_or_self) ? $class_or_self : $class_or_self->new;
143   my $column = column_name($self);
144   my $result = $self->db->with_transaction(sub {
145     my $query = qq|UPDATE | . $self->meta->table . qq| SET ${column} = ? WHERE id = ?|;
146     my $sth   = $self->db->dbh->prepare($query) || SL::X::DBUtilsError->throw(msg => 'reorder_list error', db_error => $self->db->dbh->errstr);
147
148     foreach my $new_position (1 .. scalar(@ids)) {
149       $sth->execute($new_position, $ids[$new_position - 1]) || SL::X::DBUtilsError->throw(msg => 'reorder_list error', db_error => $sth->errstr);
150     }
151
152     $sth->finish;
153
154     1;
155   });
156
157   return $result;
158 }
159
160 sub configure_acts_as_list {
161   my ($class, %params) = @_;
162
163   $list_spec{$class} = {
164     group_by    => $params{group_by},
165     column_name => $params{column_name},
166   };
167 }
168
169 #
170 # Helper functions
171 #
172
173 sub get_group_by_where {
174   my ($self)   = @_;
175
176   my $group_by = get_spec(ref $self, 'group_by') || [];
177   $group_by    = [ $group_by ] if $group_by && !ref $group_by;
178
179   my (@where, @values);
180   foreach my $column (@{ $group_by }) {
181     my $value = $self->$column;
182     push @values, $value if defined $value;
183     push @where,  defined($value) ? "(${column} = ?)" : "(${column} IS NULL)";
184   }
185
186   return (join(' AND ', @where), @values);
187 }
188
189 sub set_position {
190   my ($self) = @_;
191   my $column = column_name($self);
192   my $value  = $self->$column;
193
194   return 1 if defined($value) && ($value != -1);
195
196   my $table               = $self->meta->table;
197   my ($group_by, @values) = get_group_by_where($self);
198   $group_by               = " AND ${group_by}" if $group_by;
199   my $sql                 = <<SQL;
200     SELECT COALESCE(MAX(${column}), 0)
201     FROM ${table}
202     WHERE (${column} <> -1)
203       ${group_by}
204 SQL
205
206   my $max_position = $self->db->dbh->selectrow_arrayref($sql, undef, @values)->[0];
207   $self->$column($max_position + 1);
208
209   return 1;
210 }
211
212 sub remove_position {
213   my ($self) = @_;
214   my $column = column_name($self);
215
216   $self->load;
217   my $value = $self->$column;
218   return 1 unless defined($value) && ($value != -1);
219
220   my $table               = $self->meta->table;
221   my ($group_by, @values) = get_group_by_where($self);
222   $group_by               = ' AND ' . $group_by if $group_by;
223   my $sql                 = <<SQL;
224     UPDATE ${table}
225     SET ${column} = ${column} - 1
226     WHERE (${column} > ?)
227      ${group_by}
228 SQL
229
230   $self->db->dbh->do($sql, undef, $value, @values);
231
232   return 1;
233 }
234
235 sub do_move {
236   my ($self, $direction) = @_;
237
238   croak "Object has not been saved yet" unless $self->id;
239
240   my $column       = column_name($self);
241   my $old_position = $self->$column;
242   croak "No position set yet" unless defined($old_position) && ($old_position != -1);
243
244   my $table                                        = $self->meta->table;
245   my ($comp_sel, $comp_upd, $min_max, $plus_minus) = $direction eq 'up' ? ('<', '>=', 'MAX', '+') : ('>', '<=', 'MIN', '-');
246   my ($group_by, @values)                          = get_group_by_where($self);
247   $group_by                                        = ' AND ' . $group_by if $group_by;
248   my $sql                                          = <<SQL;
249     SELECT ${min_max}(${column})
250     FROM ${table}
251     WHERE (${column} <>          -1)
252       AND (${column} ${comp_sel} ?)
253       ${group_by}
254 SQL
255
256   my $new_position = $self->db->dbh->selectrow_arrayref($sql, undef, $old_position, @values)->[0];
257
258   return undef unless defined $new_position;
259
260   $sql = <<SQL;
261     UPDATE ${table}
262     SET ${column} = ?
263     WHERE (${column} = ?)
264      ${group_by};
265 SQL
266
267   $self->db->dbh->do($sql, undef, $old_position, $new_position, @values);
268
269   $self->update_attributes($column => $new_position);
270 }
271
272 sub get_previous_or_next {
273   my ($self, $direction)  = @_;
274
275   my $asc_desc            = $direction eq 'next' ? 'ASC' : 'DESC';
276   my $comparator          = $direction eq 'next' ? '>'   : '<';
277   my $table               = $self->meta->table;
278   my $column              = column_name($self);
279   my $primary_key_col     = ($self->meta->primary_key)[0];
280   my ($group_by, @values) = get_group_by_where($self);
281   $group_by               = " AND ${group_by}" if $group_by;
282   my $sql                 = <<SQL;
283     SELECT ${primary_key_col}
284     FROM ${table}
285     WHERE (${column} ${comparator} ?)
286       ${group_by}
287     ORDER BY ${column} ${asc_desc}
288     LIMIT 1
289 SQL
290
291   my $id = ($self->db->dbh->selectrow_arrayref($sql, undef, $self->$column, @values) || [])->[0];
292
293   return $id ? $self->_get_manager_class->find_by(id => $id) : undef;
294 }
295
296 sub column_name {
297   my ($self) = @_;
298   my $column = get_spec(ref $self, 'column_name');
299   return $column if $column;
300   return $self->can('sortkey') ? 'sortkey' : 'position';
301 }
302
303 sub get_spec {
304   my ($class, $key) = @_;
305
306   return undef unless $list_spec{$class};
307   return $list_spec{$class}->{$key};
308 }
309
310 1;
311 __END__
312
313 =pod
314
315 =encoding utf8
316
317 =head1 NAME
318
319 SL::DB::Helper::ActsAsList - Mixin for managing ordered items by a
320 column
321
322 =head1 SYNOPSIS
323
324   package SL::DB::SomeObject;
325   use SL::DB::Helper::ActsAsList [ PARAMS ];
326
327   package SL::Controller::SomeController;
328   ...
329   # Assign a position automatically
330   $obj = SL::DB::SomeObject->new(description => 'bla');
331   $obj->save;
332
333   # Move items up and down
334   $obj = SL::DB::SomeOBject->new(id => 1)->load;
335   $obj->move_position_up;
336   $obj->move_position_down;
337
338   # Adjust all remaining positions automatically
339   $obj->delete
340
341 This mixin assumes that the mixing package's table contains a column
342 called C<position> or C<sortkey> (for legacy tables). This column is
343 set automatically upon saving the object if it hasn't been set
344 already. If it hasn't then it will be set to the maximum position used
345 in the table plus one.
346
347 When the object is deleted all positions greater than the object's old
348 position are decreased by one.
349
350 C<PARAMS> will be given to L<configure_acts_as_list> and can be used to
351 set the column name.
352
353 =head1 CLASS FUNCTIONS
354
355 =over 4
356
357 =item C<configure_acts_as_list %params>
358
359 Configures the mixin's behaviour. Will get called automatically with the
360 include parameters. C<%params> can contain the following values:
361
362 =over 2
363
364 =item C<column_name>
365
366 The name of the column containing the position. If not set explicitly
367 then the mixin will use C<sortkey> if the model contains such a column
368 (only for legacy tables) and C<position> otherwise.
369
370 =item C<group_by>
371
372 An optional column name (or array reference of column names) by which
373 to group. If a table contains items for several distinct sets and each
374 set has its own sorting then this can be used.
375
376 An example would be requirement spec text blocks. They have a column
377 called C<output_position> that selects where to output the text blocks
378 (either before or after the sections). Furthermore these text blocks
379 each belong to a single requirement spec document. So each combination
380 of C<requirement_spec_id> and C<output_position> should have its own
381 set of C<position> values, which can be achieved by configuring this
382 mixin with C<group_by = [qw(requirement_spec_id output_position)]>.
383
384 =back
385
386 =back
387
388 =head1 INSTANCE FUNCTIONS
389
390 =over 4
391
392 =item C<move_position_up>
393
394 Swaps the object with the object one step above the current one
395 regarding their sort order by exchanging their C<position> values.
396
397 =item C<move_position_down>
398
399 Swaps the object with the object one step below the current one
400 regarding their sort order by exchanging their C<position> values.
401
402 =item C<add_to_list %params>
403
404 Adds this item to the list. The parameter C<position> is required and
405 can be one of C<first>, C<last>, C<before> and C<after>. With C<first>
406 the item is inserted as the first item in the list and all other
407 item's positions are shifted up by one. For C<position = last> the
408 item is inserted at the end of the list.
409
410 For C<before> and C<after> an additional parameter C<reference> is
411 required. This is either a Rose model instance or the primary key of
412 one. The current item will then be inserted either before or after the
413 referenced item by shifting all the appropriate item positions up by
414 one.
415
416 If C<$self>'s positional column is already set when this function is
417 called then L</remove_from_list> will be called first before anything
418 else is done.
419
420 After this function C<$self>'s positional column has been set and
421 saved to the database.
422
423 =item C<remove_from_list>
424
425 Sets this items positional column to C<-1>, saves it and moves all
426 following items up by 1.
427
428 =item C<get_previous_in_list>
429
430 Fetches the previous item in the list. Returns C<undef> if C<$self> is
431 already the first one.
432
433 =item C<get_next_in_list>
434
435 Fetches the next item in the list. Returns C<undef> if C<$self> is
436 already the last one.
437
438 =item C<get_full_list>
439
440 Fetches all items in the same list as C<$self> and returns them as an
441 array reference.
442
443 =item C<reorder_list @ids>
444
445 Re-orders the objects given in C<@ids> by their position in C<@ids> by
446 updating all of their positional columns. Each element in
447 C<@positions> must be the ID of an object. The new position is the
448 ID's index inside C<@ids> plus one (meaning the first element's new
449 position will be 1 and not 0).
450
451 This works by executing SQL "UPDATE" statements directly.
452
453 Returns the result of the whole transaction (trueish in case of
454 success).
455
456 This method can be called both as a class method or an instance
457 method.
458
459 =back
460
461 =head1 BUGS
462
463 Nothing here yet.
464
465 =head1 AUTHOR
466
467 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
468
469 =cut