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   configure_acts_as_list($importing, @params);
  18
  19   $importing->before_save(  sub { SL::DB::Helper::ActsAsList::set_position(@_)    });
  20   $importing->before_delete(sub { SL::DB::Helper::ActsAsList::remove_position(@_) });
  21
  22   # Don't 'goto' to Exporters import, it would try to parse @params
  23   __PACKAGE__->export_to_level(1, $class, @EXPORT);
  24 }
  25
  26 #
  27 # Exported functions
  28 #
  29
  30 sub move_position_up {
  31   my ($self) = @_;
  32   do_move($self, 'up');
  33 }
  34
  35 sub move_position_down {
  36   my ($self) = @_;
  37   do_move($self, 'down');
  38 }
  39
  40 sub remove_from_list {
  41   my ($self) = @_;
  42
  43   return $self->db->with_transaction(sub {
  44     remove_position($self);
  45
  46     # Set to -1 manually because $self->update_attributes() would
  47     # trigger the before_save() hook from this very plugin assigning a
  48     # number at the end of the list again.
  49     my $table           = $self->meta->table;
  50     my $column          = column_name($self);
  51     my $primary_key_col = ($self->meta->primary_key)[0];
  52     my $sql             = <<SQL;
  53       UPDATE ${table}
  54       SET ${column} = -1
  55       WHERE ${primary_key_col} = ?
  56 SQL
  57     $self->db->dbh->do($sql, undef, $self->$primary_key_col);
  58     $self->$column(undef);
  59   });
  60 }
  61
  62 sub add_to_list {
  63   my ($self, %params) = @_;
  64
  65   croak "Invalid parameter 'position'" unless ($params{position} || '') =~ m/^ (?: before | after | first | last ) $/x;
  66
  67   my $column = column_name($self);
  68
  69   $self->remove_from_list if ($self->$column // -1) != -1;
  70
  71   if ($params{position} eq 'last') {
  72     set_position($self);
  73     $self->save;
  74     return;
  75   }
  76
  77   my $table               = $self->meta->table;
  78   my $primary_key_col     = ($self->meta->primary_key)[0];
  79   my ($group_by, @values) = get_group_by_where($self);
  80   $group_by               = " AND ${group_by}" if $group_by;
  81   my $new_position;
  82
  83   if ($params{position} eq 'first') {
  84     $new_position = 1;
  85
  86   } else {
  87     # Can only be 'before' or 'after' -- 'last' has been checked above
  88     # already.
  89
  90     my $reference = $params{reference};
  91     croak "Missing parameter 'reference'" if !$reference;
  92
  93     my $reference_pos;
  94     if (ref $reference) {
  95       $reference_pos = $reference->$column;
  96     } else {
  97       ($reference_pos) = $self->db->dbh->selectrow_array(qq|SELECT ${column} FROM ${table} WHERE ${primary_key_col} = ?|, undef, $reference);
  98     }
  99
 100     $new_position = $params{position} eq 'before' ? $reference_pos : $reference_pos + 1;
 101   }
 102
 103   my $query = <<SQL;
 104     UPDATE ${table}
 105     SET ${column} = ${column} + 1
 106     WHERE (${column} > ?)
 107       ${group_by}
 108 SQL
 109
 110   return $self->db->with_transaction(sub {
 111     $self->db->dbh->do($query, undef, $new_position - 1, @values);
 112     $self->update_attributes($column => $new_position);
 113   });
 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->with_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     1;
 154   });
 155
 156   return $result;
 157 }
 158
 159 sub configure_acts_as_list {
 160   my ($class, %params) = @_;
 161
 162   $list_spec{$class} = {
 163     group_by    => $params{group_by},
 164     column_name => $params{column_name},
 165   };
 166 }
 167
 168 #
 169 # Helper functions
 170 #
 171
 172 sub get_group_by_where {
 173   my ($self)   = @_;
 174
 175   my $group_by = get_spec(ref $self, 'group_by') || [];
 176   $group_by    = [ $group_by ] if $group_by && !ref $group_by;
 177
 178   my (@where, @values);
 179   foreach my $column (@{ $group_by }) {
 180     my $value = $self->$column;
 181     push @values, $value if defined $value;
 182     push @where,  defined($value) ? "(${column} = ?)" : "(${column} IS NULL)";
 183   }
 184
 185   return (join(' AND ', @where), @values);
 186 }
 187
 188 sub set_position {
 189   my ($self) = @_;
 190   my $column = column_name($self);
 191   my $value  = $self->$column;
 192
 193   return 1 if defined($value) && ($value != -1);
 194
 195   my $table               = $self->meta->table;
 196   my ($group_by, @values) = get_group_by_where($self);
 197   $group_by               = " AND ${group_by}" if $group_by;
 198   my $sql                 = <<SQL;
 199     SELECT COALESCE(MAX(${column}), 0)
 200     FROM ${table}
 201     WHERE (${column} <> -1)
 202       ${group_by}
 203 SQL
 204
 205   my $max_position = $self->db->dbh->selectrow_arrayref($sql, undef, @values)->[0];
 206   $self->$column($max_position + 1);
 207
 208   return 1;
 209 }
 210
 211 sub remove_position {
 212   my ($self) = @_;
 213   my $column = column_name($self);
 214
 215   $self->load;
 216   my $value = $self->$column;
 217   return 1 unless defined($value) && ($value != -1);
 218
 219   my $table               = $self->meta->table;
 220   my ($group_by, @values) = get_group_by_where($self);
 221   $group_by               = ' AND ' . $group_by if $group_by;
 222   my $sql                 = <<SQL;
 223     UPDATE ${table}
 224     SET ${column} = ${column} - 1
 225     WHERE (${column} > ?)
 226      ${group_by}
 227 SQL
 228
 229   $self->db->dbh->do($sql, undef, $value, @values);
 230
 231   return 1;
 232 }
 233
 234 sub do_move {
 235   my ($self, $direction) = @_;
 236
 237   croak "Object has not been saved yet" unless $self->id;
 238
 239   my $column       = column_name($self);
 240   my $old_position = $self->$column;
 241   croak "No position set yet" unless defined($old_position) && ($old_position != -1);
 242
 243   my $table                                        = $self->meta->table;
 244   my ($comp_sel, $comp_upd, $min_max, $plus_minus) = $direction eq 'up' ? ('<', '>=', 'MAX', '+') : ('>', '<=', 'MIN', '-');
 245   my ($group_by, @values)                          = get_group_by_where($self);
 246   $group_by                                        = ' AND ' . $group_by if $group_by;
 247   my $sql                                          = <<SQL;
 248     SELECT ${min_max}(${column})
 249     FROM ${table}
 250     WHERE (${column} <>          -1)
 251       AND (${column} ${comp_sel} ?)
 252       ${group_by}
 253 SQL
 254
 255   my $new_position = $self->db->dbh->selectrow_arrayref($sql, undef, $old_position, @values)->[0];
 256
 257   return undef unless defined $new_position;
 258
 259   $sql = <<SQL;
 260     UPDATE ${table}
 261     SET ${column} = ?
 262     WHERE (${column} = ?)
 263      ${group_by};
 264 SQL
 265
 266   $self->db->dbh->do($sql, undef, $old_position, $new_position, @values);
 267
 268   $self->update_attributes($column => $new_position);
 269 }
 270
 271 sub get_previous_or_next {
 272   my ($self, $direction)  = @_;
 273
 274   my $asc_desc            = $direction eq 'next' ? 'ASC' : 'DESC';
 275   my $comparator          = $direction eq 'next' ? '>'   : '<';
 276   my $table               = $self->meta->table;
 277   my $column              = column_name($self);
 278   my $primary_key_col     = ($self->meta->primary_key)[0];
 279   my ($group_by, @values) = get_group_by_where($self);
 280   $group_by               = " AND ${group_by}" if $group_by;
 281   my $sql                 = <<SQL;
 282     SELECT ${primary_key_col}
 283     FROM ${table}
 284     WHERE (${column} ${comparator} ?)
 285       ${group_by}
 286     ORDER BY ${column} ${asc_desc}
 287     LIMIT 1
 288 SQL
 289
 290   my $id = ($self->db->dbh->selectrow_arrayref($sql, undef, $self->$column, @values) || [])->[0];
 291
 292   return $id ? $self->_get_manager_class->find_by(id => $id) : undef;
 293 }
 294
 295 sub column_name {
 296   my ($self) = @_;
 297   my $column = get_spec(ref $self, 'column_name');
 298   return $column if $column;
 299   return $self->can('sortkey') ? 'sortkey' : 'position';
 300 }
 301
 302 sub get_spec {
 303   my ($class, $key) = @_;
 304
 305   return undef unless $list_spec{$class};
 306   return $list_spec{$class}->{$key};
 307 }
 308
 309 1;
 310 __END__
 311
 312 =pod
 313
 314 =encoding utf8
 315
 316 =head1 NAME
 317
 318 SL::DB::Helper::ActsAsList - Mixin for managing ordered items by a
 319 column
 320
 321 =head1 SYNOPSIS
 322
 323   package SL::DB::SomeObject;
 324   use SL::DB::Helper::ActsAsList [ PARAMS ];
 325
 326   package SL::Controller::SomeController;
 327   ...
 328   # Assign a position automatically
 329   $obj = SL::DB::SomeObject->new(description => 'bla');
 330   $obj->save;
 331
 332   # Move items up and down
 333   $obj = SL::DB::SomeOBject->new(id => 1)->load;
 334   $obj->move_position_up;
 335   $obj->move_position_down;
 336
 337   # Adjust all remaining positions automatically
 338   $obj->delete
 339
 340 This mixin assumes that the mixing package's table contains a column
 341 called C<position> or C<sortkey> (for legacy tables). This column is
 342 set automatically upon saving the object if it hasn't been set
 343 already. If it hasn't then it will be set to the maximum position used
 344 in the table plus one.
 345
 346 When the object is deleted all positions greater than the object's old
 347 position are decreased by one.
 348
 349 C<PARAMS> will be given to L<configure_acts_as_list> and can be used to
 350 set the column name.
 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. Will get called automatically with the
 359 include parameters. C<%params> can contain the following 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