s3

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Carp;
   5 use Pod::Usage qw( pod2usage );
   6 use Getopt::Long qw( :config gnu_getopt );
   7 use English qw( -no_match_vars );
   8 my $VERSION = '0.0.1';
   9
  10 # Other recommended modules (uncomment to use):
  11 #  use IO::Prompt;
  12 #  use Readonly;
  13 use File::Basename qw( basename );
  14 use File::Spec::Functions qw( catfile );
  15 use Data::Dumper;
  16 $Data::Dumper::Indent = 1;
  17
  18 # Integrated logging facility
  19 use Log::Log4perl qw( :easy :no_extra_logdie_message );
  20 Log::Log4perl->easy_init({level => $WARN, layout => '[%d %-5p] %m%n'});
  21 my %log_level_for = (
  22    TRACE => $TRACE,
  23    DEBUG => $DEBUG,
  24    INFO  => $INFO,
  25    WARN  => $WARN,
  26    ERROR => $ERROR,
  27    FATAL => $FATAL,
  28 );
  29 my %log_name_for = map { $log_level_for{$_} => $_ } keys %log_level_for;
  30
  31 use Net::Amazon::S3;
  32 use Config::Tiny;
  33
  34 my %config = (
  35    configfile    => "$ENV{HOME}/.aws",
  36    histfile      => "$ENV{HOME}/.s3_history",
  37    'load-config' => 1,
  38    data          => '',
  39 );
  40 $config{interactive} = 1 unless @ARGV;
  41
  42 GetOptions(
  43    \%config,
  44    qw(
  45      usage! help! man! version!
  46      interactive|i!
  47      id=s secret=s debug=s
  48      delimiter=s max-keys=s marker=s dir! ls! l!
  49      meta|m=s@ header|h=s@ acl=s data=s
  50      clear! add=s@ del=s@
  51      )
  52 );
  53 pod2usage(message => "$0 $VERSION", -verbose => 99, -sections => ' ')
  54   if $config{version};
  55 pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
  56 pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
  57   if $config{help};
  58 pod2usage(-verbose => 2) if $config{man};
  59
  60 # Script implementation here
  61 get_logger('')->level($log_level_for{$config{debug}})
  62   if exists $config{debug};
  63 if ($config{'load-config'} && -r $config{configfile}) {
  64    my $tiny = Config::Tiny->read($config{configfile})->{_};
  65    while (my ($k, $v) = each %$tiny) {
  66       next if exists $config{$k};
  67       $config{$k} = $v;
  68    }
  69 } ## end if ($config{'load-config'...
  70 get_logger('')->level($log_level_for{$config{debug}})
  71   if exists $config{debug};
  72
  73 my $s3 = Net::Amazon::S3->new(
  74    {
  75       aws_access_key_id     => $config{id},
  76       aws_secret_access_key => $config{secret},
  77       retry                 => 1,
  78    }
  79 );
  80
  81 if ($config{interactive}) {
  82    get_logger('')->level($INFO) unless exists $config{debug};
  83    require Term::ShellUI;
  84
  85    my %commands = (
  86       list     => {desc => 'list buckets/keys'},
  87       add      => {desc => 'add bucket/key, optionally from file'},
  88       create   => {desc => 'create bucket'},
  89       copy     => {desc => 'copy one key onto another'},
  90       get      => {desc => 'retrieve a key'},
  91       show     => {desc => 'show metadata/headers for key'},
  92       meta     => {desc => 'show/set metadata for key'},
  93       acl      => {desc => 'show/set acl for bucket/key'},
  94       'delete' => {desc => 'delete bucket/key'},
  95       locate   => {desc => 'location constraint for bucket'},
  96       ls       => {desc => 'list a-la system ls'},
  97       dir      => {desc => 'list a-la system ls -l'},
  98       cp       => {desc => 'DWIM copy a-la system cp'},
  99       mv       => {desc => 'DWIM move/rename a-la system mv'},
 100       cat      => {desc => 'retrieve keys/files and print out'},
 101       rm       => {desc => 'DWIM deletion a-la system rm'},
 102    );
 103
 104    for my $command (keys %commands) {
 105       $commands{$command}{proc} = sub {
 106          launch_command($s3, \%config, $command, @_);
 107       };
 108       $commands{$command}{doc} = \&pod2doc,;
 109    } ## end for my $command (keys %commands)
 110
 111    my $term = Term::ShellUI->new(
 112       app      => 's3',
 113       prompt   => 's3> ',
 114       commands => {
 115          %commands,
 116          help => {
 117             desc   => 'print helpful stuff about this program',
 118             args   => sub { shift->help_args(undef, @_); },
 119             method => sub { shift->help_call(undef, @_); }
 120          },
 121          "h"   => {alias => "help", exclude_from_completion => 1},
 122          "?"   => {alias => "help", exclude_from_completion => 1},
 123          debug => {
 124             desc => 'set the debug level',
 125             doc  => <<END,
 126     debug [<level>]
 127     Level is any among:
 128     * TRACE
 129     * DEBUG
 130     * INFO
 131     * WARN
 132     * ERROR
 133     * FATAL
 134
 135     If not specified, it simply prints the current debug level.
 136 END
 137             proc => sub {
 138                if (my ($debug) = @_) {
 139                   if (exists $log_level_for{uc $debug}) {
 140                      get_logger('')->level($log_level_for{uc $debug});
 141                   }
 142                   else {
 143                      ERROR "unknown log level $debug";
 144                   }
 145                } ## end if (my ($debug) = @_)
 146
 147                ALWAYS "currently in debug level ",
 148                  $log_name_for{get_logger()->level()};
 149                return;
 150             },
 151          },
 152          quit => {
 153             method => sub {
 154                INFO "exiting...\n";
 155                $_[0]->exit_requested(1);
 156             },
 157          },
 158          exit => {alias => 'quit', exclude_from_completion => 1},
 159          q    => {alias => 'quit', exclude_from_completion => 1},
 160       },
 161       history_file => $config{histfile},
 162    );
 163    INFO 'Using ' . $term->{term}->ReadLine . "\n";
 164    $term->run();
 165 } ## end if ($config{interactive...
 166 else {
 167    launch_command($s3, \%config, @ARGV);
 168 }
 169
 170 sub pod2doc {
 171    my ($self, $command, $name) = @_;
 172    open my $fh, '<', $0
 173      or return ERROR 'sorry, could not grab help stuff';
 174
 175    my @section;
 176    while (<$fh>) {
 177       next unless /^=item B<< $name/;
 178       @section = $_;
 179       last;
 180    }
 181    @section or return ERROR 'sorry, could not grab help stuff';
 182
 183    my $indent = 0;
 184    while (<$fh>) {
 185       last      if /^=item B<</;
 186       ++$indent if /^=over/;
 187       last      if /^=back/ && --$indent < 0;
 188       push @section, $_;
 189    } ## end while (<$fh>)
 190
 191    my $section = join '', @section;
 192    open my $pfh, '<', \$section
 193      or return ERROR 'sorry, could not grab help stuff';
 194    open my $opfh, '>', \my $formatted_section
 195      or return ERROR 'sorry, could not grab help stuff';
 196
 197    require Pod::PlainText;
 198    my $parser = Pod::PlainText->new(sentence => 0, width => 72);
 199    $parser->parse_from_filehandle($pfh, $opfh);
 200    return $formatted_section;
 201 } ## end sub pod2doc
 202
 203 sub launch_command {
 204    my ($s3, $ext_config, $command, @args) = @_;
 205
 206    $command =~ s/^_+//;
 207    DEBUG "command: $command";
 208
 209    my $sub = Operations->can($command)
 210      or LOGDIE "unknown command '$command'";
 211
 212    my %config;
 213    {
 214       local @ARGV = @args;
 215       GetOptions(
 216          \%config,
 217          qw(
 218            delimiter=s max-keys=s marker=s dir! ls! l!
 219            meta|m=s@ header|h=s@ acl=s data=s
 220            clear! add=s@ del=s@
 221            )
 222       );
 223       @args = @ARGV;
 224    }
 225
 226    $sub->($s3, {%$ext_config, %config}, @args);
 227 } ## end sub launch_command
 228
 229 sub s3path_split {
 230    my ($s3path) = @_;
 231    LOGDIE "no s3path" unless defined $s3path;
 232
 233    for my $regex (
 234 qr{\A (?: : | s3:// | http://s3.amazonaws.com/ ) ([^/]+) (?: / (.*))?}mxs,
 235       qr{\A http:// (.+?) \.s3\.amazonaws\.com (?: / (.*))?}mxs,
 236       qr{\A http:// ([^/]+) (?: / (.*))?}mxs,    # keep as last option
 237      )
 238    {
 239       if (my ($bucket, $key) = $s3path =~ /$regex/) {
 240          return ($bucket, $key);
 241       }
 242    } ## end for my $regex (...
 243    return;
 244 } ## end sub s3path_split
 245
 246 sub is_s3path {
 247    return scalar s3path_split($_[0]);
 248 }
 249
 250 sub fh2fh {
 251    my ($ifh, $ofh) = @_;
 252    while (1) {
 253       my $nread = read($ifh, my $buffer, 4096);
 254       LOGDIE "read(): $OS_ERROR" unless defined $nread;
 255       last unless $nread;
 256       print {$ofh} $buffer
 257         or LOGDIE "print(): $OS_ERROR";
 258    } ## end while (1)
 259    return;
 260 } ## end sub fh2fh
 261
 262 sub cp_local {
 263    my ($src, $dst) = @_;
 264
 265    # Copy the file locally...
 266    my @src_stat = stat $src or LOGDIE "stat(): $OS_ERROR";
 267
 268    $dst = resolve_dst($dst, $src);
 269    my @dst_stat = stat $dst;
 270    LOGDIE "refusing to copy '$src' onto itself"
 271      if @dst_stat
 272         && ($src_stat[0] == $dst_stat[0])
 273         && ($src_stat[1] == $dst_stat[1]);
 274
 275    open my $ifh, '<', $src
 276      or LOGDIE "open('$src'): $OS_ERROR";
 277    binmode $ifh;
 278    open my $ofh, '>', $dst
 279      or LOGDIE "open('$dst'): $OS_ERROR";
 280    binmode $ofh;
 281
 282    fh2fh($ifh, $ofh);
 283
 284    close $ofh or LOGDIE "close('$dst'): $OS_ERROR";
 285    close $ifh;
 286 } ## end sub cp_local
 287
 288 sub resolve_dst {
 289    my ($dst, $src) = @_;
 290
 291    return is_s3path($dst)
 292      ? ((substr($dst, -1, 1) eq '/') ? $dst . basename($src) : $dst)
 293      : ((-d $dst) ? catfile($dst, basename($src)) : $dst);
 294 } ## end sub resolve_dst
 295
 296 package Operations;
 297 use strict;
 298 use warnings;
 299 use Log::Log4perl qw( :easy );
 300 use Data::Dumper;
 301 use English qw( -no_match_vars );
 302
 303 BEGIN {    # dirty hack to access the right logger
 304    no warnings 'redefine';
 305    *_default_logger = sub { return Log::Log4perl::get_logger->(''); };
 306 }
 307
 308 sub _canonical {
 309    my ($bucket, $key) = @_;
 310    $key = '' unless defined $key;
 311    return "http://$bucket.s3.amazonaws.com/$key";
 312 }
 313
 314 sub list {
 315    my ($s3, $config, $s3path) = @_;
 316
 317    if (scalar(@_) == 2) {
 318       DEBUG 'getting buckets list';
 319       my $response = $s3->buckets() or LOGDIE $s3->err();
 320       for my $bucket (@{$response->{buckets}}) {
 321          (my $date = $bucket->creation_date()) =~ s/T/ /;
 322          print {*STDOUT} $date, ' ', _canonical($bucket->bucket()), "\n";
 323       }
 324       return;
 325    } ## end if (scalar(@_) == 2)
 326
 327    my ($bucket, $prefix) = main::s3path_split($s3path);
 328    my %parameters = (bucket => $bucket);
 329    $parameters{prefix} = $prefix if defined $prefix;
 330
 331    for my $field (qw( delimiter max-keys marker )) {
 332       $parameters{$field} = $config->{$field}
 333         if exists $config->{$field};
 334    }
 335
 336    if ($config->{ls}) {
 337       $parameters{prefix} = ''
 338         unless defined($parameters{prefix});
 339       $parameters{prefix} .= '/'
 340         if length($parameters{prefix})
 341            && substr($parameters{prefix}, -1, 1) ne '/';
 342       $parameters{delimiter} = '/';
 343    } ## end if ($config->{ls})
 344
 345    DEBUG Dumper \%parameters;
 346
 347    my $response =
 348      (exists($parameters{'max-keys'}) || exists($parameters{marker}))
 349      ? $s3->list_bucket(\%parameters)
 350      : $s3->list_bucket_all(\%parameters);
 351    $response or LOGDIE $s3->err();
 352    DEBUG Dumper($response);
 353
 354    for my $file (@{$response->{common_prefixes} || []},
 355       @{$response->{keys} || []})
 356    {
 357       my ($name, $date, $size, $owner) =
 358         ($file . '/', '1970-01-01T00:00:00.000Z', 0, '-', 0);
 359       ($name, $date, $size, $owner) =
 360         @{$file}{qw(key last_modified size owner_displayname)}
 361         if ref $file;
 362       $name = _canonical($bucket, $name);
 363       $date =~ s/T/ /;
 364
 365       if ($config->{l}) {    # a-la ls -l
 366          print {*STDOUT} "---------- 1 $owner $owner $size $date $name\n";
 367       }
 368       else {                 # simply the name
 369          print {*STDOUT} $name, "\n";
 370       }
 371    } ## end for my $file (@{$response...
 372
 373    print {*STDOUT} ":next-marker $response->{next_marker}\n"
 374      if $response->{is_truncated};
 375
 376    return;
 377 } ## end sub list
 378
 379 sub ls {
 380    my ($s3, $config, @rest) = @_;
 381    LOGDIE 'no bucket or path' unless @rest;
 382    list($s3, {%$config, ls => 1}, $_) for @rest;
 383    return;
 384 } ## end sub ls
 385
 386 sub dir {
 387    my ($s3, $config, @rest) = @_;
 388    return ls($s3, {%$config, l => 1}, @rest);
 389 }
 390
 391 sub add {
 392    my ($s3, $config, $s3path, $filename) = @_;
 393
 394    my ($bucket, $key) = main::s3path_split($s3path);
 395
 396    LOGDIE "no bucket" unless defined($bucket);
 397    return create($s3, $config, $bucket) unless defined $key;
 398
 399    my %options;
 400    for my $meta (@{$config->{meta} || []}) {
 401       my ($name, $value) = split /:/, $meta, 2;
 402       $options{'x-amz-meta-' . lc($name)} = $value;
 403    }
 404    for my $header (@{$config->{header} || []}) {
 405       my ($name, $value) = split /:/, $header, 2;
 406       $options{$name} = $value;
 407    }
 408    $options{'x-amz-acl'} = $config->{acl}
 409      if exists $config->{acl};
 410
 411    my $bucket_obj = $s3->bucket($bucket);
 412    my $response =
 413      defined($filename)
 414      ? $bucket_obj->add_key_filename($key, $filename, \%options)
 415      : $bucket_obj->add_key($key, $config->{data}, \%options);
 416    LOGDIE $s3->err() unless $response;
 417
 418    INFO "key '$key' successfully created in bucket '$bucket'";
 419    return;
 420 } ## end sub add
 421
 422 sub create {
 423    my ($s3, $config, $bucket) = @_;
 424    INFO "adding bucket '$bucket'";
 425    my %parameters = (bucket => $bucket);
 426    $parameters{acl_short} = $config->{acl} if exists $config->{acl};
 427    $parameters{location_constraint} = $config->{location}
 428      if exists $config->{location};
 429    $s3->add_bucket(\%parameters) or LOGDIE $s3->err();
 430    INFO "bucket '$bucket' correctly created";
 431    return;
 432 } ## end sub create
 433
 434 sub copy {
 435    my ($s3, $config, $src, $dst) = @_;
 436
 437    LOGDIE "no parameters" unless defined $src;
 438    my ($src_bucket, $src_key) = main::s3path_split($src);
 439    LOGDIE "invalid source" unless defined $src_key;
 440
 441    LOGDIE "no destination" unless defined $dst;
 442    my ($dst_bucket, $dst_key) = main::s3path_split($dst);
 443    LOGDIE "invalid destination" unless defined $dst_key;
 444
 445    LOGDIE "refusing to copy '$src' onto itself"
 446      if ($src_bucket eq $dst_bucket) && ($src_key eq $dst_key);
 447
 448    my %options;
 449    for my $meta (@{$config->{meta} || []}) {
 450       my ($name, $value) = split /:/, $meta, 2;
 451       $options{'x-amz-meta-' . lc($name)} = $value;
 452    }
 453    for my $header (@{$config->{header} || []}) {
 454       my ($name, $value) = split /:/, $header, 2;
 455       $options{$name} = $value;
 456    }
 457    $options{'x-amz-acl'} = $config->{acl}
 458      if exists $config->{acl};
 459
 460    $s3->bucket($dst_bucket)
 461      ->copy_key($dst_key, "/$src_bucket/$src_key", \%options)
 462      or LOGDIE $s3->err();
 463
 464    INFO "copied '$dst' from '$src'";
 465    return;
 466 } ## end sub copy
 467
 468 sub get {
 469    my ($s3, $config, $s3path, $filename) = @_;
 470
 471    my ($bucket, $key) = main::s3path_split($s3path);
 472    LOGDIE "no key in '$s3path'" unless defined $key;
 473
 474    my $response;
 475    eval {
 476       my $bobj = $s3->bucket($bucket);
 477       $response =
 478         defined($filename)
 479         ? $bobj->get_key_filename($key, 'GET',
 480          main::resolve_dst($filename, $key))
 481         : $bobj->get_key($key);
 482       1;
 483    } or LOGDIE "server error getting '$s3path': ", $s3->err();
 484
 485    LOGDIE "missing content for '$s3path'" unless defined $response;
 486    print {*STDOUT} $response->{value};
 487
 488    return;
 489 } ## end sub get
 490
 491 =begin comment
 492
 493 Can perform both cp and mv, this is only the "framework" logic
 494 that uses $callback_for in order to understand which operations
 495 has to be applied exactly in the different situations. The
 496 $callback_for is an hash reference with the following keys:
 497
 498  l2l - local to local
 499  l2r - local to remote (S3)
 500  r2l - remote (S3) to local
 501  r2r - remote (S3) to remote (S3)
 502
 503 =end comment
 504
 505 =cut
 506
 507 sub _cp_or_mv {
 508    my ($callback_for, $s3, $config, @list) = @_;
 509
 510    LOGDIE "no parameters" unless @list;
 511    my $dst = pop @list;
 512    LOGDIE "no destination" unless @list > 0;
 513
 514    if (main::is_s3path($dst)) {    # dst is in S3
 515       LOGDIE "$dst should end with '/' with more than one source"
 516         if (@list > 1) && (substr($dst, -1, 1) ne '/');
 517       for my $src (@list) {
 518          my $this_dst = main::resolve_dst($dst, $src);
 519          if (main::is_s3path($src)) {
 520             $callback_for->{r2r}->($s3, $config, $src, $this_dst);
 521          }
 522          else {
 523             my %config = %$config;
 524
 525             if (!grep { m/^content[_-]type:/imxs }
 526                @{$config{header} || []})
 527             {
 528                require LWP::MediaTypes;
 529                my $ct = LWP::MediaTypes::guess_media_type($src);
 530                INFO "Content-Type for '$src' set to $ct";
 531                unshift @{$config{header}}, 'Content-Type:' . $ct;
 532             } ## end if (!grep { m/^content[_-]type:/imxs...
 533
 534             unshift @{$config{meta}}, 'stat:' . join ',', stat $src;
 535
 536             $callback_for->{l2r}->($s3, \%config, $src, $this_dst);
 537          } ## end else [ if (main::is_s3path($src...
 538       } ## end for my $src (@list)
 539    } ## end if (main::is_s3path($dst...
 540    else {    # dst is local
 541       LOGDIE "$dst should be a directory with more than one source"
 542         if (@list > 1) && !-d $dst;
 543       main::is_s3path($_)
 544         ? $callback_for->{r2l}->($s3, $config, $_, $dst)
 545         : $callback_for->{l2l}->($s3, $config, $_, $dst)
 546         for @list;
 547    } ## end else [ if (main::is_s3path($dst...
 548
 549    return;
 550 } ## end sub _cp_or_mv
 551
 552 sub cp {
 553    return _cp_or_mv(
 554       {
 555          r2r => \&copy,
 556          l2r => sub {
 557             my ($s3, $config, $src, $dst) = @_;
 558             add($s3, $config, $dst, $src);    # swap dst and src for add!
 559          },
 560          r2l => \&get,
 561          l2l => sub {
 562             my ($s3, $config, $src, $dst);
 563             main::cp_local($src, $dst);
 564          },
 565       },
 566       @_
 567    );
 568 } ## end sub cp
 569
 570 sub mv {
 571    return _cp_or_mv(
 572       {
 573          r2r => sub {
 574             copy(@_);
 575             _delete(@_);
 576          },
 577          l2r => sub {
 578             my ($s3, $config, $src, $dst) = @_;
 579             add($s3, $config, $dst, $src);    # swap dst and src for add!
 580             unlink $src or LOGDIE "could not delete '$src': $OS_ERROR";
 581             return;
 582          },
 583          r2l => sub {
 584             get(@_);
 585             _delete(@_);
 586          },
 587          l2l => sub {
 588             my ($s3, $config, $src, $dst) = @_;
 589
 590             # Try a simple rename, if possible
 591             rename($src, $dst) and return;
 592
 593             # Fall back to copy-and-delete
 594             main::cp_local($src, $dst);
 595             unlink $src or LOGDIE "could not delete '$src': $OS_ERROR";
 596
 597             return;
 598          },
 599       },
 600       @_
 601    );
 602 } ## end sub mv
 603
 604 sub cat {
 605    my ($s3, $config, @paths) = @_;
 606    for my $path (@paths) {
 607       if (main::is_s3path($path)) {
 608          get($s3, $config, $path);
 609       }
 610       else {
 611          open my $fh, '<', $path
 612            or LOGDIE "open('$path'): $OS_ERROR";
 613          main::fh2fh($fh, \*STDOUT);
 614       }
 615    } ## end for my $path (@paths)
 616    return;
 617 } ## end sub cat
 618
 619 sub show {
 620    my ($s3, $config, $s3path) = @_;
 621
 622    my ($bucket, $key) = main::s3path_split($s3path);
 623    LOGDIE "no key in '$s3path'" unless defined $key;
 624
 625    my $response;
 626    eval {
 627       $response = $s3->bucket($bucket)->head_key($key);
 628       1;
 629    } or LOGDIE "server error getting '$s3path' metadata: ", $s3->err();
 630
 631    LOGDIE "'$s3path': no such s3path"
 632      unless defined $response;
 633
 634    delete $response->{value};
 635    for my $header (sort keys %$response) {
 636       (my $hname = $header) =~ s/_/-/g;
 637       next if ($hname ne $header) && exists $response->{$hname};
 638       print {*STDOUT} "$header: $response->{$header}\n";
 639    }
 640
 641    return;
 642 } ## end sub show
 643
 644 sub _set_meta {
 645    my ($s3, $config, $hmeta, $bucket, $key) = @_;
 646
 647    $hmeta = {} if $config->{clear};
 648
 649    for my $deletion (@{$config->{del} || []}) {
 650       my ($target, $value) = split /:/, $deletion, 2;
 651       $target = lc "x-amz-meta-$target";
 652       next unless exists $hmeta->{$target};
 653       $value = $hmeta->{$target} unless defined $value;
 654       delete $hmeta->{$target} if $hmeta->{$target} eq $value;
 655    } ## end for my $deletion (@{$config...
 656
 657    for my $addition (@{$config->{add} || []}) {
 658       my ($target, $value) = split /:/, $addition, 2;
 659       $hmeta->{lc("x-amz-meta-$target")} = $value;
 660    }
 661
 662    $s3->bucket($bucket)->edit_metadata($key, $hmeta)
 663      or LOGDIE 'editing metadata failed: ', $s3->err();
 664    return;
 665 } ## end sub _set_meta
 666
 667 sub meta {
 668    my ($s3, $config, $s3path) = @_;
 669
 670    my ($bucket, $key) = main::s3path_split($s3path);
 671    LOGDIE "no key in '$s3path'" unless defined $key;
 672
 673    my $response;
 674    eval {
 675       $response = $s3->bucket($bucket)->head_key($key);
 676       1;
 677    } or LOGDIE "server error getting '$s3path' metadata: ", $s3->err();
 678
 679    LOGDIE "'$s3path': no such s3path"
 680      unless defined $response;
 681
 682    my %meta =
 683      map { lc($_) => $response->{$_} }
 684      grep { m/^x-amz-meta-/mxsi } keys %$response;
 685
 686    return _set_meta($s3, $config, \%meta, $bucket, $key)
 687      if exists($config->{clear})
 688         || exists($config->{add})
 689         || exists($config{del});
 690
 691    for my $meta (sort keys %meta) {
 692       (my $name = $meta) =~ s/^x-amz-meta-//mxsi;
 693       print {*STDOUT} "$name: $response->{$meta}\n";
 694    }
 695
 696    return;
 697 } ## end sub meta
 698
 699 sub _set_acl {
 700    my ($s3, $config, $acl, $bucket, $key) = @_;    # yes, @key as array
 701
 702    $acl->clear() if $config->{clear};
 703
 704    for my $deletion (@{$config->{del} || []}) {
 705       my ($target, $permission) = split /:/, $deletion, 2;
 706       $acl->delete($target, $permission);
 707    }
 708
 709    for my $addition (@{$config->{add} || []}) {
 710       my ($target, $permission) = split /:/, $addition, 2;
 711       $acl->add($target, $permission);
 712    }
 713
 714    INFO "setting ACL:\n", $acl->stringify();
 715
 716    my %conf = (acl => $acl);
 717    $conf{key} = $key if defined $key;
 718    $s3->bucket($bucket)->set_acl(\%conf)
 719      or LOGDIE "setting ACL: ", $s3->err();
 720
 721    return;
 722 } ## end sub _set_acl
 723
 724 sub acl {
 725    return _acl_noACL(@_) unless Net::Amazon::S3::ACL->can('new');
 726
 727    my ($s3, $config, $s3path) = @_;
 728
 729    my ($bucket, $key) = main::s3path_split($s3path);
 730    my $acl = $s3->bucket($bucket)->get_acl({key => $key});
 731
 732    LOGDIE "could not get ACL for '$s3path': ", $s3->err()
 733      unless $acl;
 734
 735    return _set_acl($s3, $config, $acl, $bucket, $key)
 736      if exists($config->{clear})
 737         || exists($config->{add})
 738         || exists($config{del});
 739
 740    print {*STDOUT} $acl->stringify();
 741
 742    return;
 743 } ## end sub acl
 744
 745 sub _acl_noACL {
 746    my ($s3, $config, $s3path) = @_;
 747
 748    LOGDIE 'sorry, get Net::Amazon::S3::ACL to set up the ACL'
 749      if exists($config->{clear})
 750         || exists($config->{add})
 751         || exists($config{del});
 752
 753    my ($bucket, $key) = main::s3path_split($s3path);
 754    my $acl = $s3->bucket($bucket)->get_acl($key);
 755
 756    LOGDIE "could not get ACL for '$s3path': ", $s3->err()
 757      unless $acl;
 758
 759    print {*STDOUT} $acl;
 760    return;
 761 } ## end sub _acl_noACL
 762
 763 sub _delete {
 764    my ($s3, $config, $s3path) = @_;
 765
 766    my ($bucket, $key) = main::s3path_split($s3path);
 767
 768    my $bobj = $s3->bucket($bucket);
 769    if (!defined $key) {    # bucket-oriented operation
 770       INFO "deleting bucket '$bucket'";
 771       $bobj->delete_bucket() or LOGDIE $s3->err();
 772    }
 773    else {
 774       INFO "deleting key '$key' in bucket '$bucket'";
 775       $bobj->delete_key($key)
 776         or LOGDIE "unable to delete '$s3path': ", $s3->err();
 777    }
 778
 779    return;
 780 } ## end sub _delete
 781
 782 {
 783    no warnings;
 784    *delete = \&delete;
 785 }
 786
 787 sub locate {
 788    my ($s3, $config, $s3path) = @_;
 789
 790    my ($bucket, $key) = main::s3path_split($s3path);
 791    my $response = $s3->bucket($bucket)->get_location_constraint()
 792      || '(plausibly US)';
 793    print {*STDOUT} $response, "\n";
 794
 795    return;
 796 } ## end sub locate
 797
 798 sub rm {
 799    my ($s3, $config, @list) = @_;
 800    _delete($s3, $config, $_) for @list;
 801    return;
 802 }
 803
 804 __END__
 805
 806 =head1 NAME
 807
 808 s3 - command-line utility to interact with S3
 809
 810 =head1 VERSION
 811
 812 Ask the version number to the script itself, calling:
 813
 814    shell$ s3 --version
 815
 816 =head1 USAGE
 817
 818    s3 [--usage] [--help] [--man] [--version]
 819
 820    # generic options, valid for all commands
 821    s3 <command> [--id <id>] [--secret <string>] [--interactive|-i]
 822
 823    # "pure" commands
 824    s3 acl    [--clear] [--add <spec>] [--del <spec>] <s3path>
 825
 826    s3 add    [--meta <meta>] [--header <header>] [--acl <acl>]
 827              [--data <data>] [--location <place>] <s3path> [<filename>]
 828
 829    s3 copy   [--meta <meta>] [--header <header>] [--acl <acl>]
 830              <s3path-src> <s3path-dst>
 831
 832    s3 create [--acl <acl>] [--location <location>] <bucket-name>
 833
 834    s3 delete <s3path>
 835
 836    s3 get    <s3path> [<filename|dirname>]
 837
 838    s3 list   [--ls] [-l] [--delimiter <string>] [--max-keys <n>]
 839              [--marker <n>] [<s3path>]
 840
 841    s3 locate <s3path>
 842
 843    s3 meta   [--clear] [--add <spec>] [--del <spec>] <s3path>
 844
 845    s3 show   <s3path>
 846
 847    # "filesyste-oriented" commands
 848    s3 cat [<filename|s3path>] ...
 849
 850    s3 cp  <src> [<src2> [<src3 ...]] <dst>
 851
 852    s3 dir [--delimiter <string>] [--max-keys <n>]
 853           [--marker <n>] [<s3path>]
 854
 855    s3 ls  [-l] [--delimiter <string>] [--max-keys <n>]
 856           [--marker <n>] [<s3path>]
 857
 858    s3 rm  <s3path> [<s3path2> [<s3path3> ...]]
 859
 860
 861 =head1 EXAMPLES
 862
 863    # list all buckets
 864    s3 list
 865
 866    # create two buckets
 867    s3 create mybucket
 868    s3 add mybucket-x
 869
 870    # locate a bucket
 871    s3 localte :mybucket
 872
 873    # list keys
 874    s3 list :mybucket
 875    s3 list :mybucket/some/prefix
 876    s3 ls :mybucket/some/directory
 877    s3 ls -l :mybucket/some/directory/extended-print
 878    s3 dir :mybucket/ditto/as/above
 879
 880    # create a key
 881    s3 add :mybucket/empty
 882    s3 add :mybucket/cmdline-data --data 'Hello, World!'
 883    s3 add :mybucket/fromfile /path/to/somefile
 884
 885    # get contents of one or more keys
 886    s3 get :mybucket/key
 887    s3 get :mybucket/tofile /path/to/destination
 888    s3 cat :mybucket/key :mybucket-x/key-x
 889
 890    # make copies...
 891    s3 copy :mybucket/source :mybucket-x/destination-copy
 892    s3 cp /path/to/localfile :mybucket/remote
 893    s3 cp /local/file :mybucket/remote/file /path/to/localdir
 894    s3 cp /local/file :mybucket/remote/file :mybucket-x/path/to/remotedir/
 895
 896    # move stuff
 897    s3 mv :mybucket/something /path/to/local
 898    s3 mv /path/to/something :mybucket/remote
 899    s3 mv /local/file :mybucket/remote/file :mybucket-x/path/to/remotedir/
 900
 901    # get headers
 902    s3 show :mybucket/somekey
 903
 904    # get/set metadata
 905    s3 meta :mybucket/somekey
 906    s3 meta :mybucket/somekey --add colour:green --del taste:awful
 907
 908    # get/set ACL
 909    s3 acl :mybucket
 910    s3 acl :mybucket/somekey
 911    s3 acl :mybucket/somekey --add any:read --del foo@example.com
 912
 913    # finally, delete stuff
 914    s3 delete :mybucket/somekey
 915    s3 delete :mybucket-x
 916    s3 rm :mybucket
 917
 918 =head1 DESCRIPTION
 919
 920 =for l'autore, da riempire:
 921    Fornite una descrizione completa del modulo e delle sue caratteristiche.
 922    Aiutatevi a strutturare il testo con le sottosezioni (=head2, =head3)
 923    se necessario.
 924
 925 =head2 S3 paths
 926
 927 We use the term I<s3path> to indicate an identifier for a S3 resource.
 928 A I<s3path> can be any of the following:
 929
 930    :bucket
 931    :bucket/prefix
 932
 933    s3://bucket
 934    s3://bucket/prefix
 935
 936    http://s3.amazonaws.com/bucket
 937    http://s3.amazonaws.com/bucket/prefix
 938
 939    http://bucket.s3.amazonaws.com/
 940    http://bucket.s3.amazonaws.com/prefix
 941
 942    http://bucket
 943    http://bucket/prefix
 944
 945 The forms with the I<bucket> only are I<improper s3path>s, while the
 946 other ones are I<proper s3path>s because they include a I<key>/I<prefix>
 947 as well. When the I<prefix> resolves to a I<key> we'll say that it's
 948 a I<full s3path>.
 949
 950
 951 =head2 Permissions
 952
 953 Permissions can be specified in the short or in the long form, depending
 954 on the command. In particular, only the L</acl> command support the long
 955 format, so we'll discuss the short one here.
 956
 957 The short format for specifying permissions is a single word that can
 958 be any of the following options (from the Amazon API documentation):
 959
 960 =over
 961
 962 =item B<< private >>
 963
 964 Owner gets FULL_CONTROL. No one else has any access
 965 rights.  This is the default.
 966
 967 =item B<< public-read >>
 968
 969 Owner gets FULL_CONTROL and the anonymous principal is
 970 granted READ access. If this policy is used on an object, it can be
 971 read from a browser with no authentication.
 972
 973 =item B<< public-read-write >>
 974
 975 Owner gets FULL_CONTROL, the anonymous principal
 976 is granted READ and WRITE access. This is a useful policy to apply
 977 to a bucket, if you intend for any anonymous user to PUT objects
 978 into the bucket.
 979
 980 =item B<< authenticated-read >>
 981
 982 Owner gets FULL_CONTROL, and any principal
 983 authenticated as a registered Amazon S3 user is granted READ
 984 access.
 985
 986 =back
 987
 988 =head1 OPTIONS
 989
 990 Each command can have its own options, but the following ones are either
 991 common to them all or meta-options.
 992
 993 =over
 994
 995 =item --help
 996
 997 print a somewhat more verbose help, showing usage, this description of
 998 the options and some examples from the synopsis.
 999
1000 =item --id <ID>
1001
1002 the Amazon AWS ID for the account to use. By default, it is read
1003 from F<~/.aws>.
1004
1005 =item --interactive | -i
1006
1007 enter the I<interactive> mode, which gives you a shell to work with
1008 (which saves you to type "s3 " in front of each command, and will hopefully
1009 give you more power in the future).
1010
1011 =item --man
1012
1013 print out the full documentation for the script.
1014
1015 =item --secret <secret>
1016
1017 the secret shared with Amazon for signing requests. By default, it
1018 is read from F<~/.aws>.
1019
1020 =item --usage
1021
1022 print a concise usage line and exit.
1023
1024 =item --version
1025
1026 print the version of the script.
1027
1028 =back
1029
1030 B<NOTE>: when called without any parameter, the L</--interactive> options
1031 is implied.
1032
1033 =head1 COMMANDS
1034
1035 Most commands have different behaviours in the DWIM spirit.
1036
1037 The commands can be broadly divided into two main classes: the I<pure>
1038 S3 commands, and the ones that somehow impose a filesystem metaphor.
1039
1040 The I<pure> commands are a more or less direct mapping of the API that
1041 S3 exposes. It's well suited when you have to do S3 operations, e.g. as
1042 part of some scripting.
1043
1044 The I<filesystem>-oriented commands work under the assumption that
1045 keys are organised hyerarchically similarly to a filesystem; it's probably
1046 best suited when you want to somehow forget that you're dealing with S3,
1047 and want to get the job done while feeling at home.
1048
1049 =head2 I<Pure> Commands
1050
1051 =over
1052
1053 =item B<< acl [--clear] [--add <spec>] [--del <spec>] <s3path> >>
1054
1055 get or set the Access Control Policy for the given resource. Options
1056 are:
1057
1058 =over
1059
1060 =item --add <target>:<permission>
1061
1062 add/set the given permission to the given target. Can be given multiple
1063 times.
1064
1065 =item --clear
1066
1067 clear all the currently set permissions
1068
1069 =item --del <target>[:<permission>]
1070
1071 delete a permission. If the permission is specified, deletes the
1072 permission only if present; otherwise, the given target is wiped out.
1073 Can be given multiple times.
1074
1075 =back
1076
1077 B<NOTE>: to be able to set the ACL, you'll need L<Net::Amazon::S3::ACL> and
1078 a modified version of L<Net::Amazon::S3::Bucket> (hopefully the needed
1079 changes will be included in L<Net::Amazon::S3> some day). If you want, you
1080 can find the module and the patch at
1081 L<http://rt.cpan.org/Ticket/Display.html?id=38847> (take the stuff in the
1082 reply, ignore the first message).
1083
1084 =item B<< add [--meta <meta>] [--header <header>] [--acl <acl>] [--data <data>] [--location <place>] <s3path> [<filename>] >>
1085
1086 add a resource in S3.
1087
1088 If the path contains a bucket name only, then this command is simply a
1089 shortcut for the L</create> command, which creates the bucket. In this
1090 case, all parameters specific to L</add> are ignored.
1091
1092 If the path contains a key as well, then the relative object is
1093 created. In this case there are the following options:
1094
1095 =over
1096
1097 =item --acl <permission>
1098
1099 set the short permission (see L</Permissions>).
1100
1101 =item --data <data>
1102
1103 get the data to be put into the object from the command line; useful
1104 for one-shot file creations.
1105
1106 =item --header <name>:<value>
1107
1108 set the given header in the request to be sent to the server. Can
1109 be given multiple times.
1110
1111 =item --location <place>
1112
1113 see L</copy>.
1114
1115 =item --meta <name>:<value>
1116
1117 add metadata when creating the object; it's actually a shorthand
1118 for the I<header> option above. Can be given multiple times.
1119
1120 =back
1121
1122
1123 =item B<< copy [--meta <meta>] [--header <header>] [--acl <acl>]  <s3path-src> <s3path-dst> >>
1124
1125 copy one object into a new one, remotely.
1126
1127 During the copy, metadata are usually preserved unless you provide yours.
1128 The same does not apply to ACL, which defaults to... the default.
1129
1130 Options:
1131
1132 =over
1133
1134 =item --acl <permission>
1135
1136 set the short permission (see L</Permissions>).
1137
1138 =item --header <name>:<value>
1139
1140 set the given header in the request to be sent to the server. Can
1141 be given multiple times.
1142
1143 =item --meta <name>:<value>
1144
1145 add metadata when creating the object; it's actually a shorthand
1146 for the I<header> option above. Can be given multiple times.
1147
1148 =back
1149
1150 =item B<< create [--acl <acl>] [--location <location>] <bucket-name> >>
1151
1152 create a bucket. Options are:
1153
1154 =over
1155
1156 =item --acl <permission>
1157
1158 set the short permission (see L</Permissions>).
1159
1160 =item --location <place>
1161
1162 the location constraint for bucket storage. Currently, you can only
1163 specify C<EU>; otherwise, the bucket will be created in the phantomatic
1164 I<default location>, which should be in the U.S.
1165
1166 =back
1167
1168 =item B<< delete <s3path> >>
1169
1170 remove the given resource, whether it's a bucket or a fully qualified key.
1171
1172 =item B<< get <s3path> [<filename|dirname>] >>
1173
1174 get the given object (I<s3path> must be a proper path).
1175
1176 If a filename is given, the object's contents are printed to the file.
1177
1178 If a directory name is given, the object's contents are saved into a file
1179 in the given directory. The filename will be derived by the object's key
1180 using the C<basename> function in L<File::Basename>.
1181
1182 By default, the object's contents will be printed to standard output.
1183
1184 =item B<< list [--ls] [-l] [--delimiter <string>] [--max-keys <n>] [--marker <n>] [s3path>] >>
1185
1186 If issued without any parameter, the list of buckets will be printed.
1187
1188 If the I<s3path> is improper (i.e. it only contains the bucket name),
1189 then the full list of objects in the bucket is printed out.
1190
1191 If the I<s3path> is proper, two possible behaviours are possible:
1192
1193 =over
1194
1195 =item *
1196
1197 if L</--ls> is given the I<prefix> in the
1198 I<s3path> is regarded as an equivalent I<directory name> and the contents
1199 of this I<virtual directory> are printed out. In this case, the I<prefix>
1200 is automatically appended with a forward slash C</> if it lack one, and
1201 the search is set with the forward slash C</> delimiter.
1202
1203 =item *
1204
1205 otherwise, all objects matching the given I<prefix> are printed out.
1206
1207 =back
1208
1209 Options:
1210
1211 =over
1212
1213 =item --ls
1214
1215 treat the keys as UNIX-style paths, and mimic what the C<ls> command would
1216 do. This option implies L</--delimiter> set to C</>.
1217
1218 =item -l
1219
1220 be verbose when printing out. When a list of keys is printed, it vaguely
1221 resembles what the command C<ls -l> does.
1222
1223 =item --delimiter <string>
1224
1225 =item --max-keys <n>
1226
1227 =item --marker <n>
1228
1229 See Amazon AWS documentation for these three parameters. The first one
1230 allows you to restrict the output list by summarising keys, while the other
1231 two allow for pagination (by default any pagination is handled automatically,
1232 at the expense of making repeated calls under the hood).
1233
1234 =back
1235
1236
1237 =item B<< locate <s3path> >>
1238
1239 get the location for the given resource (this is actually the location
1240 of the bucket). Note that, due to an inconsistent behaviour in
1241 L<Net::Amazon::S3>, you can't be certain if a given bucket is in the
1242 I<default> location or if an error occurred.
1243
1244 =item B<< meta [--clear] [--add <spec>] [--del <spec>] <s3path> >>
1245
1246 change the metadata for the given resource. Options:
1247
1248 =over
1249
1250 =item --add <name>:<value>
1251
1252 add the given metadata.
1253
1254 =item --clear
1255
1256 remove all metadata.
1257
1258 =item --del <name>[:<value>]
1259
1260 delete the metadata given by I<name>. If a I<value> is present, then the
1261 metadata is removed only if its current value is equal to I<value>.
1262
1263 =back
1264
1265 =item B<< show <s3path> >>
1266
1267 get information about the given object (I<s3path> must be a fully qualified
1268 one). These info include all the headers of a HEAD request for the given
1269 resource.
1270
1271 =back
1272
1273 =head2 I<Filesystem-Oriented> Commands
1274
1275 These commands rely upon the assumption that the keys for the objects
1276 can be treated like normal UNIX paths in a filesystem. Each command tries
1277 to reproduce the corresponding system command, at least in its basic
1278 functionality.
1279
1280 =over
1281
1282 =item B<< cat [<filename|s3path>] ... >>
1283
1284 output the given resources. Note that you can intermix local files and
1285 remote I<s3path>s.
1286
1287 =item B<< cp  <src> [<src2> [<src3 ...]] <dst> >>
1288
1289 make a copy. Both the source and the destinations can be (independently)
1290 in the local system or in the S3 one. Yes, also the local copy should
1291 work.
1292
1293 Like the C<cp> system command, if you want to specify more than two
1294 arguments the last one must be a directory. For the local filesystem the
1295 check is straightforward; for the remote one the destination must end with
1296 a slash.
1297
1298 If the destination is a directory, the target filename will be derived
1299 by the corresponding source filename by means of C<basename> in
1300 L<File::Basename>.
1301
1302 =item B<< dir [--delimiter <string>] [--max-keys <n>] [--marker <n>] [<s3path>] >>
1303
1304 same as command L</ls> with the C<-l> option.
1305
1306 =item B<< ls  [-l] [--delimiter <string>] [--max-keys <n>] [--marker <n>] [<s3path>] >>
1307
1308 same as the L</list> command, with the L</--ls> option.
1309
1310 =item B<< mv  <src> [<src2> [<src3 ...]] <dst> >>
1311
1312 move resources. Both the source and the destinations can be (independently)
1313 in the local system or in the S3 one. Yes, also the local mv should
1314 work.
1315
1316 Like the C<mv> system command, if you want to specify more than two
1317 arguments the last one must be a directory. For the local filesystem the
1318 check is straightforward; for the remote one the destination must end with
1319 a slash.
1320
1321 If the destination is a directory, the target filename will be derived
1322 by the corresponding source filename by means of C<basename> in
1323 L<File::Basename>.
1324
1325 B<NOTE>: the "mv" is more or less implemented as a copy-then-delete. If
1326 the deletion isn't successful, the copy is B<NOT> deleted. This is
1327 regarded as a feature, considering that traffic wit S3 is paid.
1328
1329 =item B<< rm <s3path> [<s3path2> [<s3path3> ...]] >>
1330
1331 remove the given resources.
1332
1333 =back
1334
1335
1336 =head1 DIAGNOSTICS
1337
1338 Any error coming from AWS S3 is printed on the standard output.
1339
1340
1341 =head1 CONFIGURATION AND ENVIRONMENT
1342
1343 s3 reads its configuration from F<~/.aws>. It should be an INI-style
1344 file like this:
1345
1346    id = your-AWS-id
1347    secret = your-AWS-secret
1348
1349
1350 =head1 DEPENDENCIES
1351
1352 =over
1353
1354 =item *
1355
1356 L<Net::Amazon::S3>
1357
1358 =item *
1359
1360 L<Net::Amazon::S3::ACL>, which will hopefully be included in
1361 L<Net::Amazon::S3>. This is only required if you want to play with
1362 ACLs.
1363
1364 =item *
1365
1366 L<Log::Log4perl>
1367
1368 =item *
1369
1370 L<Config::Tiny>
1371
1372 =item *
1373
1374 L<Term::ShellUI> if you want to use the L</--interactive> mode.
1375
1376 =back
1377
1378
1379 =head1 BUGS AND LIMITATIONS
1380
1381 No bugs have been reported.
1382
1383 Please report any bugs or feature requests through http://rt.cpan.org/
1384
1385 The "cp" and "mv" commands sort-of do what the system counterparts do
1386 when source and destination are in the local filesystem. The "sort-of"
1387 means that at the end you'll have a file in the destination that has
1388 the same contents of the source, and the source will be deleted if it's
1389 a "mv". Anything beyond this (e.g. permissions, etc.) is not handled.
1390
1391 An interactive mode could be added.
1392
1393
1394 =head1 AUTHOR
1395
1396 Flavio Poletti C<flavio@polettix.it>
1397
1398
1399 =head1 LICENCE AND COPYRIGHT
1400
1401 Copyright (c) 2008, Flavio Poletti C<flavio@polettix.it>. All rights reserved.
1402
1403 This script is free software; you can redistribute it and/or
1404 modify it under the same terms as Perl itself. See L<perlartistic>
1405 and L<perlgpl>.
1406
1407 Questo script è software libero: potete ridistribuirlo e/o
1408 modificarlo negli stessi termini di Perl stesso. Vedete anche
1409 L<perlartistic> e L<perlgpl>.
1410
1411
1412 =head1 DISCLAIMER OF WARRANTY
1413
1414 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
1415 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
1416 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
1417 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
1418 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1419 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
1420 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
1421 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
1422 NECESSARY SERVICING, REPAIR, OR CORRECTION.
1423
1424 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
1425 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
1426 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
1427 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
1428 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
1429 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
1430 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
1431 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
1432 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
1433 SUCH DAMAGES.
1434
1435 =head1 NEGAZIONE DELLA GARANZIA
1436
1437 Poiché questo software viene dato con una licenza gratuita, non
1438 c'è alcuna garanzia associata ad esso, ai fini e per quanto permesso
1439 dalle leggi applicabili. A meno di quanto possa essere specificato
1440 altrove, il proprietario e detentore del copyright fornisce questo
1441 software "così com'è" senza garanzia di alcun tipo, sia essa espressa
1442 o implicita, includendo fra l'altro (senza però limitarsi a questo)
1443 eventuali garanzie implicite di commerciabilità e adeguatezza per
1444 uno scopo particolare. L'intero rischio riguardo alla qualità ed
1445 alle prestazioni di questo software rimane a voi. Se il software
1446 dovesse dimostrarsi difettoso, vi assumete tutte le responsabilità
1447 ed i costi per tutti i necessari servizi, riparazioni o correzioni.
1448
1449 In nessun caso, a meno che ciò non sia richiesto dalle leggi vigenti
1450 o sia regolato da un accordo scritto, alcuno dei detentori del diritto
1451 di copyright, o qualunque altra parte che possa modificare, o redistribuire
1452 questo software così come consentito dalla licenza di cui sopra, potrà
1453 essere considerato responsabile nei vostri confronti per danni, ivi
1454 inclusi danni generali, speciali, incidentali o conseguenziali, derivanti
1455 dall'utilizzo o dall'incapacità di utilizzo di questo software. Ciò
1456 include, a puro titolo di esempio e senza limitarsi ad essi, la perdita
1457 di dati, l'alterazione involontaria o indesiderata di dati, le perdite
1458 sostenute da voi o da terze parti o un fallimento del software ad
1459 operare con un qualsivoglia altro software. Tale negazione di garanzia
1460 rimane in essere anche se i dententori del copyright, o qualsiasi altra
1461 parte, è stata avvisata della possibilità di tali danneggiamenti.
1462
1463 Se decidete di utilizzare questo software, lo fate a vostro rischio
1464 e pericolo. Se pensate che i termini di questa negazione di garanzia
1465 non si confacciano alle vostre esigenze, o al vostro modo di
1466 considerare un software, o ancora al modo in cui avete sempre trattato
1467 software di terze parti, non usatelo. Se lo usate, accettate espressamente
1468 questa negazione di garanzia e la piena responsabilità per qualsiasi
1469 tipo di danno, di qualsiasi natura, possa derivarne.
1470
1471 =cut