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