projekt kivitendo

package SL::Webdav;

use strict;

use parent qw(Rose::Object);

use Encode qw(decode);

use File::Spec;

use SL::Common;

use SL::Webdav::File;

use SL::Webdav::Object;

use SL::Webdav::VersionScheme::Serial;

use SL::Webdav::VersionScheme::Timestamp;

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

  scalar => [ qw(type number) ],

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

);

my %type_to_path = (

  sales_quotation         => 'angebote',

  sales_order             => 'bestellungen',

  request_quotation       => 'anfragen',

  purchase_order          => 'lieferantenbestellungen',

  sales_delivery_order    => 'verkaufslieferscheine',

  purchase_delivery_order => 'einkaufslieferscheine',

  credit_note             => 'gutschriften',

  invoice                 => 'rechnungen',

  purchase_invoice        => 'einkaufsrechnungen',

  part                    => 'waren',

  service                 => 'dienstleistungen',

  assembly                => 'erzeugnisse',

);

sub get_all_files {

  my ($self) = @_;

  my @objects = $self->get_all_objects;

  my %files_by_name;

  for my $obj (@objects) {

    my $filename = join '.', grep $_, $obj->basename, $obj->extension;

    my $file = $files_by_name{$filename} ||= SL::Webdav::File->new(filename => $filename, webdav => $self, loaded => 1);

    $file->add_objects($obj);

  }

  return values %files_by_name;

}

sub get_all_objects {

  my ($self) = @_;

  my $path = $self->webdav_path;

  my @objects;

  my $base_path = $ENV{'SCRIPT_NAME'};

  $base_path =~ s|[^/]+$||;

  if (opendir my $dir, $path) {

    foreach my $file (sort { lc $a cmp lc $b } map { decode("UTF-8", $_) } readdir $dir) {

      next if (($file eq '.') || ($file eq '..'));

      my $fname = $file;

      $fname  =~ s|.*/||;

      push @objects, SL::Webdav::Object->new(filename => $fname, webdav => $self);

    }

    closedir $dir;

    return @objects;

  }

}

sub get_all_latest {

  my ($self) = @_;

  my @files = $self->get_all_files;

  map { ($_->versions)[-1] } @files;

}

sub _sanitized_number {

  my $number = $_[0]->number;

  $number =~ s|[/\\]|_|g;

  $number;

}

sub webdav_path {

  my ($self) = @_;

  die "No client set in \$::auth" unless $::auth->client;

  die "Need number"               unless $self->number;

  my $type = $type_to_path{$self->type};

  die "Unknown type"              unless $type;

  my $path = File::Spec->catdir("webdav", $::auth->client->{id}, $type, $self->_sanitized_number);

  if (!-d $path) {

    Common::mkdir_with_parents($path);

  }

  return $path;

}

sub init_version_scheme {

  SL::Webdav::VersionScheme::Timestamp->new;

}

1;

__END__

=encoding utf-8

=head1 NAME

SL::Webdav - Webdav manipulation

=head1 SYNOPSIS

  # get list of all documents for this record

  use SL::Webdav;

  my $webdav = SL::Webdav->new(

    type     => 'part',

    number   => $number,

  );

  # gives you SL::Webdav::File instances

  my $webdav_files = $webdav->get_all_files;

  # gives you the objects instead

  my $webdav_objects = $webdav->get_all_objects;

  # gives you only the latest objects

  my $webdav_objects = $webdav->get_all_latest;

  # physical path to this dir

  my $path = $webdav->webdav_path;

=head1 DESCRIPTION

This module is a wrapper around the webdav storage mechanism with some simple

document management functionality.

This is not a replacement for real document management, mostly because the

underlying webdav storage ist not fully under our control. It's common practice

to allow people direct samba access to the webdav, so all versioning

information need to be encoded into the filename of a file, and nonsensical

filenames must not break assumptions.

This module is intended to be used if you need to scan the folder for

previously saved files and need to build a list to display for it.

If you need to manipulate the versions of a file, see L<SL::Webdav::File>

If you need to access a file directly for download or metadata, see L<SL::Webdav::Object>

=head1 FUNCTIONS

=over 4

=item C<get_all_objects>

Returns all L<SL::Webdav::Objects> found.

=item C<get_all_files>

Returns all objects sorted into L<SL::Webdav::File>s.

=item C<get_all_latest>

Returns only the latest object of each L<SL::Webdav::File> found.

=item C<webdav_path>

Returns the physical path to this webdav object.

=back

=head1 VERSIONING SCHEME

You may register a versioning scheme object to hangdle versioning. It is

expected to implement the following methods:

=over 4

=item C<separator>

Must return a string that will be used to separate basename and version part of

filenames in generating and parsing.

=item C<extract_regexp>

Must return a regexp that will match a versioning string at the end of a

filename after the extension has been stripped off. It will be surrounded by

captures.

=item C<cmp>

Must return a comparison function that will be invoked with two

L<SL::Webdav::Object> instances.

=item C<first_version>

Must return a string representing the version of the first of a series of objects.

May return undef.

=item C<next_version>

Will be called with the latest L<SL::Webdav::Object> and must return a new version string.

=item C<keep_last_version>

Will be called with the latest L<SL::Webdav::Object>. Truish return value will

cause the latest object to be overwritten instead of creating a new version.

=back

=head1 BUGS AND CAVEATS

=over 4

=item *

File operations are inconsistently L<File::Spec>ed.

=back

=head1 SEE ALSO

L<SL::Webdav::File>, L<SL::Webdav::Object>

=head1 AUTHOR

Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>

=cut

package SL::Webdav::File;

use strict;

use parent qw(Rose::Object);

use File::Spec;

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

  scalar => [ qw(webdav filename loaded) ],

  array  => [

    qw(objects),

    add_objects => { interface => 'push', hash_key => 'objects' },

  ],

);

sub versions {

  $_[0]->load unless $_[0]->loaded;

  my $cmp = $_[0]->webdav->version_scheme->cmp;

  sort { $cmp->($a, $b) } $_[0]->objects;

}

sub latest_version {

  ($_[0]->versions)[-1]

}

sub load {

  my ($self) = @_;

  my @objects = $self->webdav->get_all_objects;

  my $ref = SL::Webdav::Object->new(filename => $self->filename, webdav => $self->webdav);

  my ($ref_basename, undef, $ref_extension) = $ref->parse_filename;

  $self->objects(grep { $_->basename eq $ref_basename && $_->extension eq $ref_extension } @objects);

  $self->loaded(1);

}

sub store {

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

  $self->load unless $self->loaded;

  my $last = $self->latest_version;

  my $object;

  if (!$last) {

    my $new_version  = $self->webdav->version_scheme->first_version;

    $object = SL::Webdav::Object->new(filename => $self->filename, webdav => $self->webdav);

    $self->add_objects($object);

  } else {

    if (!$self->webdav->version_scheme->keep_last_version($last)) {

      $params{new_version} = 1;

    }

    if ($params{new_version}) {

      my $new_version  = $self->webdav->version_scheme->next_version($last);

      my $sep          = $self->webdav->version_scheme->separator;

      my $new_filename = $last->basename . $sep . $new_version . "." . $last->extension;

      $object = SL::Webdav::Object->new(filename => $new_filename, webdav => $self->webdav);

      $self->add_objects($object);

    } else {

      $object = $last;

    }

  }

  open my $fh, '>:raw', $object->full_filedescriptor or die "could not open " . $object->filename . ": $!";

  $fh->print(${ $params{data} });

  close $fh;

  return $object;

}

1;

__END__

=encoding utf-8

=head1 NAME

SL::Webdav::File - Webdav file manipulation

=head1 SYNOPSIS

  use SL::Webdav::File;

  my $webdav_file = SL::Webdav::File->new(

    webdav   => $webdav,  # SL::Webdav instance

    filename => 'technical_drawing_AB28375.pdf',

  );

  # get existing versioned files

  my @webdav_objects = $webdav_file->versions;

  # store new version

  my $data = SL::Helper::CreatePDF->create_pdf(...);

  my $webdav_object = $webdav_file->store(data => \$data);

  # force new version

  my $webdav_object = $webdav_file->store(data => \$data, new_version => 1);

=head1 DESCRIPTION

A file in this context is the collection of all versions of a single file saved

into the webdav. This module provides methods to access and manipulate these

objects.

=head1 FUNCTIONS

=over 4

=item C<versions>

Will return all L<SL::Webdav::Object>s found in this file, sorted by version

according to the version scheme used.

=item C<latest_version>

Returns only the latest version object.

=item C<load>

Loads objects from disk.

=item C<store PARAMS>

Store a new version on disk. C<data> is expected to contain a reference to the

data to be written in raw encoding.

If param C<new_version> is set, force a new version, even if the versioning

scheme would keep the old one.

=back

=head1 SEE ALSO

L<SL::Webdav>, L<SL::Webdav::Object>

=head1 BUGS

None yet :)

=head1 AUTHOR

Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>

=cut

package SL::Webdav::Object;

use strict;

use parent qw(Rose::Object);

use DateTime;

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

  scalar => [ qw(filename webdav) ],

  'scalar --get_set_init' => [ qw(version basename extension) ],

);

sub init_basename {

  ($_[0]->parse_filename)[0];

}

sub init_version {

  ($_[0]->parse_filename)[1];

}

sub init_extension {

  ($_[0]->parse_filename)[2];

}

sub parse_filename {

  my ($self) = @_;

  my $name = $self->filename;

  my $version_re = $self->webdav->version_scheme->extract_regexp;

  my $sep        = $self->webdav->version_scheme->separator;

  my $extension = $name =~ s/\.(\w+?)$//              ? $1 : '';

  my $version   = $name =~ s/\Q$sep\E($version_re)$// ? $1 : '';

  my $basename  = $name;

  return ($basename, $version, $extension);

}

sub full_filedescriptor {

  my ($self) = @_;

  File::Spec->catfile($self->webdav->webdav_path, $self->filename);

}

sub atime {

  DateTime->from_epoch(epoch => ($_[0]->stat)[8]);

}

sub mtime {

  DateTime->from_epoch(epoch => ($_[0]->stat)[9]);

}

sub data {

  my ($self) = @_;

  open my $fh, '<:raw', $self->full_filedescriptor or die "could not open " . $self->filename . ": $!";

  local $/ = undef;

  my $data = <$fh>;

  close $fh;

  return \$data;

}

sub stat {

  my $file = $_[0]->full_filedescriptor;

  stat($file);

}

sub href {

  my ($self) = @_;

  my $base_path = $ENV{'SCRIPT_NAME'};

  $base_path =~ s|[^/]+$||;

  my $file         = $self->filename;

  my $path         = $self->webdav->webdav_path;

  my $is_directory = -d "$path/$file";

  $file  = join('/', map { $::form->escape($_) } grep { $_ } split m|/+|, "$path/$file");

  $file .=  '/' if ($is_directory);

  return "$base_path/$file";

}

1;

__END__

=encoding utf-8

=head1 NAME

SL::Webdav::Object - Webdav object wrapper

=head1 SYNOPSIS

  use SL::Webdav::Object;

  my $object = SL::Webdav::Object->new(filename => $filename, webdav => $webdav);

  my $data_ref  = $object->data;

  my $mtime     = $object->mtime;

  my $basename  = $object->basename;

  my $version   = $object->version;

  my $extension = $object->extension;

  my $link      = $object->href;

=head1 DESCRIPTION

This is a wrapper around a single object in the webdav. These objects are

thought about as immutable, and all manipulation will instead happen in the

associated L<SL::Webdav::File>.

=head1 FUNCTIONS

=over 4

=item C<basename>

Returns the basename with version and extension stripped.

=item C<version>

Returns the version string.

=item C<extension>

Returns the extension.

=item C<atime>

L<DateTime> wrapped stat[8]

=item C<mtime>

L<DateTime> wrapped stat[9]

=item C<data>

Ref to the actual data in raw encoding.

=item C<href>

URL relative to the web base dir for download.

=back

=head1 SEE ALSO

L<SL::Webdav>, L<SL::Webdav::File>

=head1 BUGS

None yet :)

=head1 AUTHOR

Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>

=cut

package SL::Webdav::VersionScheme::Serial;

use strict;

use parent qw(Rose::Object);

use DateTime;

sub separator { "-" }

sub extract_regexp { qr/\d+/ }

sub cmp { sub { $_[0]->version <=> $_[1]->version } }

sub first_version { }

sub next_version { $_[1]->version + 1 }

sub keep_last_version {

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

  if ($::lxoffice_conf->{webdav}{new_version_after_minutes}) {

    return DateTime->now <= $last->mtime + DateTime::Duration->new(minutes => $::lx_office_conf{webdav}{new_version_after_minutes});

  } else {

    return 0;

  }

}

1;

package SL::Webdav::VersionScheme::Timestamp;

use strict;

use parent qw(Rose::Object);

use POSIX;

sub separator { "_" }

sub extract_regexp { qr/\d{8}_\d{6}/ }

sub cmp { sub { $_[0]->version cmp $_[1]->version } }

sub first_version { goto &get_current_formatted_time }

sub next_version { goto &get_current_formatted_time }

sub keep_last_version {

  0;

}

sub get_current_formatted_time {

  return POSIX::strftime('%Y%m%d_%H%M%S', localtime());

}

1;