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);
   7
   8 use Carp;
   9
  10 sub import {
  11   my ($class, @params)   = @_;
  12   my $importing = caller();
  13
  14   $importing->before_save(  sub { SL::DB::Helper::ActsAsList::set_position(@_)    });
  15   $importing->before_delete(sub { SL::DB::Helper::ActsAsList::remove_position(@_) });
  16
  17   # Use 'goto' so that Exporter knows which module to import into via
  18   # 'caller()'.
  19   goto &Exporter::import;
  20 }
  21
  22 #
  23 # Exported functions
  24 #
  25
  26 sub move_position_up {
  27   my ($self) = @_;
  28   do_move($self, 'up');
  29 }
  30
  31 sub move_position_down {
  32   my ($self) = @_;
  33   do_move($self, 'down');
  34 }
  35
  36 #
  37 # Helper functions
  38 #
  39
  40 sub set_position {
  41   my ($self) = @_;
  42   if (!defined $self->position) {
  43     my $max_position = $self->db->dbh->selectrow_arrayref(qq|SELECT COALESCE(max(position), 0) FROM | . $self->meta->table)->[0];
  44     $self->position($max_position + 1);
  45   }
  46
  47   return 1;
  48 }
  49
  50 sub remove_position {
  51   my ($self) = @_;
  52
  53   $self->load;
  54   if (defined $self->position) {
  55     $self->_get_manager_class->update_all(set   => { position => \'position - 1' },
  56                                           where => [ position => { gt => $self->position } ]);
  57   }
  58
  59   return 1;
  60 }
  61
  62 sub do_move {
  63   my ($self, $direction) = @_;
  64
  65   croak "Object has not been saved yet" unless $self->id;
  66   croak "No position set yet"           unless defined $self->position;
  67
  68   my ($comp_sql, $comp_rdbo, $min_max, $plus_minus) = $direction eq 'up' ? ('<', 'ge', 'max', '+') : ('>', 'le', 'min', '-');
  69
  70   my $new_position = $self->db->dbh->selectrow_arrayref(qq|SELECT ${min_max}(position) FROM | . $self->meta->table . qq| WHERE position ${comp_sql} | . $self->position)->[0];
  71
  72   return undef unless defined $new_position;
  73
  74   $self->_get_manager_class->update_all(set   => { position => $self->position },
  75                                         where => [ position => $new_position ]);
  76   $self->update_attributes(position => $new_position);
  77 }
  78
  79 1;
  80 __END__
  81
  82 =pod
  83
  84 =encoding utf8
  85
  86 =head1 NAME
  87
  88 SL::DB::Helper::ActsAsList - Mixin for managing ordered items by a column I<position>
  89
  90 =head1 SYNOPSIS
  91
  92   package SL::DB::SomeObject;
  93   use SL::DB::Helper::ActsAsList;
  94
  95   package SL::Controller::SomeController;
  96   ...
  97   # Assign a position automatically
  98   $obj = SL::DB::SomeObject->new(description => 'bla');
  99   $obj->save;
 100
 101   # Move items up and down
 102   $obj = SL::DB::SomeOBject->new(id => 1)->load;
 103   $obj->move_position_up;
 104   $obj->move_position_down;
 105
 106   # Adjust all remaining positions automatically
 107   $obj->delete
 108
 109 This mixin assumes that the mixing package's table contains a column
 110 called C<position>. This column is set automatically upon saving the
 111 object if it hasn't been set already. If it hasn't then it will be set
 112 to the maximum position used in the table plus one.
 113
 114 When the object is deleted all positions greater than the object's old
 115 position are decreased by one.
 116
 117 =head1 FUNCTIONS
 118
 119 =over 4
 120
 121 =item C<move_position_up>
 122
 123 Swaps the object with the object one step above the current one
 124 regarding their sort order by exchanging their C<position> values.
 125
 126 =item C<move_position_down>
 127
 128 Swaps the object with the object one step below the current one
 129 regarding their sort order by exchanging their C<position> values.
 130
 131 =back
 132
 133 =head1 BUGS
 134
 135 Nothing here yet.
 136
 137 =head1 AUTHOR
 138
 139 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 140
 141 =cut