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   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   my $worker = sub {
 112     $self->db->dbh->do($query, undef, $new_position - 1, @values);
 113     $self->update_attributes($column => $new_position);
 114   };
 115
 116   return $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
 117 }
 118
 119 sub get_next_in_list {
 120   my ($self) = @_;
 121   return get_previous_or_next($self, 'next');
 122 }
 123
 124 sub get_previous_in_list {
 125   my ($self) = @_;
 126   return get_previous_or_next($self, 'previous');
 127 }
 128
 129 sub get_full_list {
 130   my ($self) = @_;
 131
 132   my $group_by = get_spec(ref $self, 'group_by') || [];
 133   $group_by    = [ $group_by ] if $group_by && !ref $group_by;
 134   my @where    = map { ($_ => $self->$_) } @{ $group_by };
 135
 136   return $self->_get_manager_class->get_all(where => \@where, sort_by => column_name($self) . ' ASC');
 137 }
 138
 139 sub reorder_list {
 140   my ($class_or_self, @ids) = @_;
 141
 142   return 1 unless @ids;
 143
 144   my $self   = ref($class_or_self) ? $class_or_self : $class_or_self->new;
 145   my $column = column_name($self);
 146   my $result = $self->db->do_transaction(sub {
 147     my $query = qq|UPDATE | . $self->meta->table . qq| SET ${column} = ? WHERE id = ?|;
 148     my $sth   = $self->db->dbh->prepare($query) || die $self->db->dbh->errstr;
 149
 150     foreach my $new_position (1 .. scalar(@ids)) {
 151       $sth->execute($new_position, $ids[$new_position - 1]) || die $sth->errstr;
 152     }
 153
 154     $sth->finish;
 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;
 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 The column name to use can be configured via L<configure_acts_as_list>.
 351
 352 =head1 CLASS FUNCTIONS
 353
 354 =over 4
 355
 356 =item C<configure_acts_as_list %params>
 357
 358 Configures the mixin's behaviour. C<%params> can contain the following
 359 values:
 360
 361 =over 2
 362
 363 =item C<column_name>
 364
 365 The name of the column containing the position. If not set explicitly
 366 then the mixin will use C<sortkey> if the model contains such a column
 367 (only for legacy tables) and C<position> otherwise.
 368
 369 =item C<group_by>
 370
 371 An optional column name (or array reference of column names) by which
 372 to group. If a table contains items for several distinct sets and each
 373 set has its own sorting then this can be used.
 374
 375 An example would be requirement spec text blocks. They have a column
 376 called C<output_position> that selects where to output the text blocks
 377 (either before or after the sections). Furthermore these text blocks
 378 each belong to a single requirement spec document. So each combination
 379 of C<requirement_spec_id> and C<output_position> should have its own
 380 set of C<position> values, which can be achieved by configuring this
 381 mixin with C<group_by = [qw(requirement_spec_id output_position)]>.
 382
 383 =back
 384
 385 =back
 386
 387 =head1 INSTANCE FUNCTIONS
 388
 389 =over 4
 390
 391 =item C<move_position_up>
 392
 393 Swaps the object with the object one step above the current one
 394 regarding their sort order by exchanging their C<position> values.
 395
 396 =item C<move_position_down>
 397
 398 Swaps the object with the object one step below the current one
 399 regarding their sort order by exchanging their C<position> values.
 400
 401 =item C<add_to_list %params>
 402
 403 Adds this item to the list. The parameter C<position> is required and
 404 can be one of C<first>, C<last>, C<before> and C<after>. With C<first>
 405 the item is inserted as the first item in the list and all other
 406 item's positions are shifted up by one. For C<position = last> the
 407 item is inserted at the end of the list.
 408
 409 For C<before> and C<after> an additional parameter C<reference> is
 410 required. This is either a Rose model instance or the primary key of
 411 one. The current item will then be inserted either before or after the
 412 referenced item by shifting all the appropriate item positions up by
 413 one.
 414
 415 If C<$self>'s positional column is already set when this function is
 416 called then L</remove_from_list> will be called first before anything
 417 else is done.
 418
 419 After this function C<$self>'s positional column has been set and
 420 saved to the database.
 421
 422 =item C<remove_from_list>
 423
 424 Sets this items positional column to C<-1>, saves it and moves all
 425 following items up by 1.
 426
 427 =item C<get_previous_in_list>
 428
 429 Fetches the previous item in the list. Returns C<undef> if C<$self> is
 430 already the first one.
 431
 432 =item C<get_next_in_list>
 433
 434 Fetches the next item in the list. Returns C<undef> if C<$self> is
 435 already the last one.
 436
 437 =item C<get_full_list>
 438
 439 Fetches all items in the same list as C<$self> and returns them as an
 440 array reference.
 441
 442 =item C<reorder_list @ids>
 443
 444 Re-orders the objects given in C<@ids> by their position in C<@ids> by
 445 updating all of their positional columns. Each element in
 446 C<@positions> must be the ID of an object. The new position is the
 447 ID's index inside C<@ids> plus one (meaning the first element's new
 448 position will be 1 and not 0).
 449
 450 This works by executing SQL "UPDATE" statements directly.
 451
 452 Returns the result of the whole transaction (trueish in case of
 453 success).
 454
 455 This method can be called both as a class method or an instance
 456 method.
 457
 458 =back
 459
 460 =head1 BUGS
 461
 462 Nothing here yet.
 463
 464 =head1 AUTHOR
 465
 466 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 467
 468 =cut