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