view release on metacpan or  search on metacpan

lib/Net/ChooseFName.pm  view on Meta::CPAN

Unless overriden, does the following: unless the option
C<hierarchical> is TRUE, all but the last path components of $f are
ignored. If the option C<site_dir> is TRUE, the host part of the URL
(as well as the port part - if non-standard) are prepended to the
filename.  The leading backslash is always stripped, and the option
C<root> is used as the lead components of the directory name.  If
$query is defined, and the option C<dir_query> is true, $f is used as
the last component of the directory, and $query as file name (with
option C<use_query> prepended).

(Dirname is assumed to be C</>-terminated.)

=cut

sub find_directory {
    my ($self, $f, $q, $url) = @_;
    # trim path until only the basename is left
    $f =~ s|(.*/)||;
    my $dirname = ($self->{hierarchical} and $1) ? $1 : '';
    $dirname =~ s#^/##;

    if (defined $q) {
      $q = "$self->{use_query}$q";
      if ($self->{dir_query}) {
	$dirname = "$dirname$f/"; # XXXX If it already exists as a file?
	$f = $q;
	$q = '';
      }
    } else {
      $q = '';
    }

    if ($self->{site_dir}) {
	eval {
	    my $site = lc $url->host;
	    my $port = $url->port;
	    my $def = $url->default_port;
	    $port = '' if $port == $def;
	    $site .= "=port$port" if length $port;
	    $dirname = "$self->{root}/$site/$dirname";
	};
    } else {
	$dirname = "$self->{root}/$dirname";
    }
    ($dirname, $f, $q)
}

=item protect_directory($dirname, $f, $append, $url, $suggested, $type, $enc)

Returns the provisional directory part of the filename.  Unless
overriden, replaces empty components by the string C<empty> preceeded
by the value of C<protect_pref> option; then applies the method
fix_component() to each component of the directory.

=cut

sub protect_directory {
    my ($self, $dirname) = @_;
    $dirname =~ s,/(?=/),/$self->{protect_pref}empty,g; # empty components
    return join '/', map($self->fix_component($_,1), split m|/|, $dirname), '';
}

=item directory_found($dirname, $f, $append, $url, $suggested, $type, $enc)

A callback to process the calculated directory name.  Unless
overriden, it creates the directory (with permissions per option
C<dir_mode>) if the option C<mkpath> is TRUE.

Actually, the directory name is the return value, so this is the last
chance to change the directory name...

=cut

sub directory_found {
    my ($self, $dirname) = @_;
    mkpath $dirname,  $self->{verbose}, $self->{dir_mode}
	if $self->{mkpath} and length $dirname and not -d $dirname;
    $dirname;
}

# Copied from LWP::Mediatypes v1.32
my %suffixEncoding = (
    'Z'   => 'compress',
    'gz'  => 'gzip',
    'hqx' => 'x-hqx',
    'uu'  => 'x-uuencode',
    'z'   => 'x-pack',
    'bz2' => 'x-bzip2',
);
my %suffixDecoding = reverse %suffixEncoding;

=item split_suffix($f, $dirname, $append, $url, $suggested, $type, $enc)

Breaks the last component $f of the filename into a pair of basename
and suffix, which are returned.  $dirname consists of other components
of the filename, $append is the string to append to the basename in
the future.

Suffix may be empty, and is supposed to contain the leading dot (if
applicable); it may contain more than one dot.  Unless overriden, the
suffix consists of all trailing non-empty started-by-dot groups with
length no more than given by the option C<max_suff_len> (not including
the leading dot).

=cut

sub split_suffix {
  my ($self, $f, $dirname, $append, $url, $suggested, $type, $enc) = @_;

  my $suff;

  my $max = $self->{max_suff_len};
  (my $base = $f) =~ s<((?:\.[^/]{1,$max})*)$><>;
  return ($base, "$1");
}


=item choose_suffix($f, $suff, $dirname, $append, $url, $suggested, $type, $enc)

Returns a pair of basename and appropriate suffix for a file.  $f is