--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
projects / kivitendo-erp.git / commitdiff