projekt kivitendo

package SL::Clipboard;

use strict;

use parent qw(Rose::Object);

use Rose::Object::MakeMethods::Generic (

  'scalar --get_set_init' => [ qw(content) ],

);

use Carp;

use List::MoreUtils qw(apply);

use List::Util qw(first);

use Scalar::Util qw(blessed);

use SL::Clipboard::RequirementSpecItem;

use SL::Clipboard::RequirementSpecTextBlock;

sub init_content {

  my $value = $::auth->get_session_value('clipboard-content');

  return ref($value) eq 'HASH' ? $value : { entries => [] };

}

sub copy {

  my ($self, $object) = @_;

  my $copied = $self->_create_copy_of($object);

  push @{ $self->content->{entries} }, $copied;

  $self->_save_content;

  return $copied;

}

sub get_entry {

  my ($self, $type) = @_;

  $type ||= qr/./;

  return first   { $_->type =~ $type          }

         reverse @{ $self->content->{entries} };

}

sub get_entries {

  my ($self, $type) = @_;

  $type ||= qr/./;

  return grep    { $_->{type} =~ $type        }

         reverse @{ $self->content->{entries} };

}

sub clear {

  my ($self) = @_;

  $self->content->{entries} = [];

  $self->_save_content;

  return $self;

}

sub _log_entries {

  my ($self) = @_;

  $::lxdebug->message(0, "Clipboard entries: " . scalar(@{ $self->content->{entries} }));

  foreach (@{ $self->content->{entries} }) {

    $::lxdebug->message(0, "  " . $_->type . ' ' . $_->timestamp . ' ' . $_->describe);

  }

}

sub _create_copy_of {

  my ($self, $object) = @_;

  croak "\$object is not a blessed reference." unless blessed($object);

  my $type   = (split(m/::/, ref($object)))[-1];

  my $copied = eval { "SL::Clipboard::${type}"->new(timestamp => DateTime->now_local) };

  croak "Class '" . ref($object) . "' not supported for copy/paste operations" if !$copied;

  $copied->content($copied->dump($object));

  return $copied;

}

sub _save_content {

  my ($self) = @_;

  $::auth->set_session_value('clipboard-content', $self->content);

  return $self;

}

1;

__END__

=pod

=encoding utf8

=head1 NAME

SL::Clipboard - A session-based clipboard mechanism for

Rose::DB::Object instances

=head1 SYNOPSIS

  # In a controller, e.g. for customers, you can react to a "copy" operation:

  my $customer = SL::DB::Customer->new(id => $::form->{id});

  SL::Clipboard->new->copy($customer);

  # Later in a paste action:

  my $copied = SL::Clipboard->new->get_entry(qr/^Customer$/);

  if ($copied) {

    my $customer = $copied->to_object;

    $customer->save;

  }

=head1 OVERVIEW

The clipboard can store an unlimited number of copies of

Rose::DB::Object instance. The instances are dumped into trees using

L<Rose::DB::Object::Helpers/as_tree>. How much of such an object is

copied depends on its type. For example, a dump of a customer object

might also include the dumps of the shipping address and contact

objects belonging to the customer.

Each clipped object is stored in the user's session along with the

timestamp of the copy operation. A controller can then query the

clipboard for the latest clipped object of a certain type (or more

types if the situation allows insertion of different types). If such a

clipped object is available it can be turned into a shiny new

Rose::DB::Object instance that can be saved to the database.

Primary key columns will always be reset as will other columns

depending on the type. For example, a copied requirement spec item

will have its C<requirement_spec_id> column cleared. The controller is

responsible for setting the columns before saving the object.

Not every Rose::DB::Object instance can be copied. For each supported

type C<Type> there must be a specialized clipboard support class

C<SL::Clipboard::Type>. The type's name is derived from the Rose class

name: by stripping the leading C<SL::DB::>. So the clipboard support

class for a requirement spec item Rose class

C<SL::DB::RequirementSpecItem> would be

C<SL::Clipboard::RequirementSpecItem>. These support classes must

inherit from L<SL::Clipboard::Base> which offers almost a full set of

support functions so that the actual specialized class has to do very

litte.

As the clipboard is session-based its contents will be lost when the

session expires (either due to timeouts or to the user logging off).

=head1 FUNCTIONS

=over 4

=item C<clear>

Clears the clipboard (removes all entries).

=item C<copy $object>

Creates a dumped copy of C<$object> and stores that copy in the

session. An unlimited number of copies of differeing types can be

made.

Returns the instance of the copied object, a sub-class of

L<SL::Clipboard::Base>.

=item C<get_entries [$type]>

Returns an array of clipped objects whose type matches the regular

expression C<$type>. If C<$type> is not given then all elements are

returned.

The array is sorted by the copy timestamp: the first element in the

array is the one most recently copied.

=item C<get_entry [$type]>

Returns the most recently clipped object whose type matches the

regular expression C<$type>. If C<$type> is not given then then then

most recently copied object is returned.

If no such object exists C<undef> is returned instead.

=back

=head1 BUGS

Nothing here yet.

=head1 AUTHOR

Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>

=cut

package SL::Clipboard::Base;

use strict;

use parent qw(Rose::Object);

use Rose::Object::MakeMethods::Generic (

  'scalar --get_set_init' => [ qw(content timestamp) ],

);

use Rose::DB::Object::Helpers ();

sub init_timestamp { die "'timestamp' property not set"; }

sub init_content   { die "'content' property not set";   }

sub type {

  my ($self_or_class) = @_;

  return (split m/::/, ref($self_or_class) ? ref($self_or_class) : $self_or_class)[-1];

}

sub reload_object {

  my ($self, $object) = @_;

  return ref($object)->new(map { $_ => $object->$_ } $object->meta->primary_key)->load;

}

sub as_tree {

  my ($self, $object, %params) = @_;

  my $tree = Rose::DB::Object::Helpers::as_tree($object, %params);

  $self->_fix_tree($tree, $object);

  return $tree;

}

sub to_object {

  my ($self) = @_;

  my $object = Rose::DB::Object::Helpers::new_from_tree("SL::DB::" . $self->type, $self->content);

  # Reset primary key columns and itime/mtime if the class supports it.

  foreach ($object->meta->primary_key, 'itime', 'mtime') {

    $object->$_(undef) if $object->can($_);

  }

  # Let sub classes fix the objects further.

  $self->_fix_object($object);

  return $object;

}

sub dump {

  my ($self, $object) = @_;

  return $self->as_tree($self->reload_object($object), max_depth => 1);

}

sub describe {

  die "'describe' method not overwritten by derived class";

}

sub _fix_object {

  my ($self, $object) = @_;

  # To be overwritten by child classes.

}

sub _fix_tree {

  my ($self, $tree, $object) = @_;

  # Delete primary key columns and itime/mtime if the class supports it.

  foreach ($object->meta->primary_key, 'itime', 'mtime') {

    delete $tree->{$_} if $object->can($_);

  }

}

1;

__END__

=pod

=encoding utf8

=head1 NAME

SL::Clipboard::Base - Base class for clipboard specialization classes

=head1 SYNOPSIS

See the synopsis of L<SL::Clipboard>.

=head1 OVERVIEW

This is a base class providing a lot of utility and

defaults. Sub-classes must overwrite at least the function

L</describe> but can overwrite others as well.

Writing a specialized sub-class for a database type involves

overwriting one or more functions. These are:

=over 4

=item * C<describe>

Must be overwritten. Returns a human-readable description of the

content. Should only be one line.

=item * C<dump>

Optional. Overwrite if sub-class needs to dump more/less than the

implementation in this class dumps.

=item * C<_fix_object>

Optional. Overwrite if re-created Rose::DB::Object instances must be

cleaned further before they're returned to the caller.

=item * C<_fix_tree>

Optional. Overwrite if the tree created during a copy operation of a

Rose::DB::Object instance must be cleaned further before it's stored.

=back

You don't have to or should not overwrite the other functions:

=over 4

=item * C<as_tree>

=item * C<reload_object>

=item * C<to_object>

=item * C<type>

=back

Don't forget to C<use> the specialized module here in Base!

=head1 FUNCTIONS

=over 4

=item C<as_tree $object, %params>

A convenience function calling L<Rose::DB::Object::Helpers/as_tree>

with C<$object> and C<%params> as parameters. Returns a hash/array

reference tree of the function.

Don't overwrite this function in sub-classes. Overwrite L</dump>

instead.

=item C<describe>

Returns a human-readable description of the content. This should only

be a single line without any markup.

Sub-classes must overwrite this function.

=item C<dump $object>

Dumps the object as a hash/array tree and returns it by calling

L<Rose::DB::Object::Helpers/as_tree>. The default implementation

reloads the object first by calling L</reload_object>. It also only

dumps the object itself, not any of the relationships, by calling

C<as_tree> with the parameter C<max_depth =E<gt> 1>.

Overwrite this in a sub-class if you need to dump more or differently

(see L<SL::Clipboard::RequirementSpecItem> for an example).

=item C<reload_object $object>

Reloads C<$object> from the database and returns a new instance. Can

be useful for sanitizing the object given to L</dump> before

converting into a tree. It is used by the default implementation of

L</dump>.

=item C<to_object>

Converts the dumped representation back to an Rose::DB::Object

instance. Several columns of the newly created object are cleared by

C<to_object> itself: the primary key columns (if any) and the columns

C<itime> and C<mtime> (if the object has such columns).

This function should not be overwritten by sub-classes. Instead,

functions can overwrite C<_fix_object> which can be used for sanitzing

the newly created object before handing it back to the caller.

=item C<type>

Returns the actual clipped type (e.g. C<RequirementSpecItem>). This is

derived from the actual class name of C<$self>.

=item C<_fix_object $object>

This function is called by L</to_object> before the object is passed

back to the caller. It does not do anything in the default

implementation, but sub-classes are free to overwrite it if they need

to sanitize the object. See L<SL::Clipboard::RequirementSpecItem> for

an example.

Its return value is ignored.

=item C<_fix_tree $tree, $object>

This function is called by L</as_tree> after dumping and before the

object is stored during a copy operation. In the default

implementation all primary key columns and the columns C<itime> and

C<mtime> (if the object has such columns) are removed from the tree.

Sub-classes are free to overwrite it if they need to sanitize the

tree. See L<SL::Clipboard::RequirementSpecItem> for an example.

C<$object> is just passed in for reference and should not be modified.

Its return value is ignored.

=back

=head1 BUGS

Nothing here yet.

=head1 AUTHOR

Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>

=cut

package SL::Clipboard::RequirementSpecItem;

use strict;

use parent qw(SL::Clipboard::Base);

use List::Util qw(sum);

use SL::Common;

use SL::Locale::String;

sub dump {

  my ($self, $object) = @_;

  return $self->as_tree(_load_children($self->reload_object($object)), exclude => sub { ref($_[0]) !~ m/::RequirementSpecItem$/ });

}

sub describe {

  my ($self) = @_;

  my $item              = $self->content;

  my $num_children      = @{ $item->{children} || [] };

  my $num_grandchildren = sum map { scalar(@{ $_->{children} || [] }) } @{ $item->{children} || [] };

  if ($item->{item_type} eq 'section') {

    return t8('Requirement spec section #1 "#2" with #3 function blocks and a total of #4 sub function blocks; preamble: "#5"',

              $item->{fb_number}, $item->{title}, $num_children, $num_grandchildren, Common::truncate($item->{description}, strip => 'full'));

  } elsif ($item->{item_type} eq 'function-block') {

    return t8('Requirement spec function block #1 with #2 sub function blocks; description: "#3"',

              $item->{fb_number}, $num_children, Common::truncate($item->{description}, strip => 'full'));

  } else {

    return t8('Requirement spec sub function block #1; description: "#2"',

              $item->{fb_number}, Common::truncate($item->{description}, strip => 'full'));

  }

}

sub _load_children {

  my ($object) = @_;

  _load_children($_) for @{ $object->children };

  return $object;

}

sub _fix_object {

  my ($self, $object) = @_;

  $object->$_(undef)     for qw(fb_number);

  $self->_fix_object($_) for @{ $object->children || [] };

}

sub _fix_tree {

  my ($self, $tree, $object) = @_;

  delete @{ $tree }{ qw(id itime mtime parent_id position requirement_spec_id) };

  $self->_fix_tree($_) for @{ $tree->{children} || [] };

}

1;

__END__

=pod

=encoding utf8

=head1 NAME

SL::Clipboard::RequirementSpecItem - Clipboard specialization for

SL::DB::RequirementSpecItem

=head1 FUNCTIONS

=over 4

=item C<describe>

Returns a human-readable description depending on the copied type

(section, function block or sub function block).

=item C<dump $object>

This specialization reloads C<$object> from the database, loads all of

its children (but only the other requirement spec items, no other

relationships) and dumps it.

=item C<_fix_object $object>

Fixes C<$object> and all of its children by clearing certain columns

like the position or function block numbers.

=back

=head1 BUGS

Nothing here yet.

=head1 AUTHOR

Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>

=cut

package SL::Clipboard::RequirementSpecTextBlock;

use strict;

use parent qw(SL::Clipboard::Base);

use SL::Common;

use SL::Locale::String;

sub describe {

  my ($self) = @_;

  return t8('Requirement spec text block "#1"; content: "#2"', $self->content->{title}, Common::truncate($self->content->{text}, strip => 'full'));

}

sub _fix_object {

  my ($self, $object) = @_;

  $object->$_(undef) for qw(output_position position requirement_spec_id);

  return $object;

}

1;

__END__

=pod

=encoding utf8

=head1 NAME

SL::Clipboard::RequirementSpecTextBlock - Clipboard specialization for

SL::DB::RequirementSpecTextBlock

=head1 FUNCTIONS

=over 4

=item C<describe>

Returns a human-readable description including the title and an

excerpt of its content.

=item C<_fix_object $object>

Fixes C<$object> by clearing certain columns like the position.

=back

=head1 BUGS

Nothing here yet.

=head1 AUTHOR

Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>

=cut