view release on metacpan or  search on metacpan

lib/App/DistSync/Util.pm  view on Meta::CPAN

    my $status = fdelete( $file );

Deleting a file if it exists

=head2 manifind

    my $files_struct = manifind($dir); # { ... }

Read direactory and returns file structure

=head2 maniread

    my $mani_struct = maniread($file, skipflag); # { ... }

Read file as manifest and returns hash structure

=head2 maniwrite

    maniwrite($file, $mani_struct);

This function writes manifest structure to manifest file

=head2 qrreconstruct

    my $r = qrreconstruct('!!perl/regexp (?i-xsm:^\s*(error|fault|no))');
    # Translate to:
    #    qr/^\s*(error|fault|no)/i

Returns regular expression (QR) by perl/regexp string. YAML form of definition

    my $r = qrreconstruct('perl/regexp (?i-xsm:^\s*(error|fault|no))');
    # Translate to:
    #    qr/^\s*(error|fault|no)/i

Not-YAML form of definition

    my $r = qrreconstruct('regexp (?i-xsm:^\s*(error|fault|no))');
    # Translate to:
    #    qr/^\s*(error|fault|no)/i

Short form of definition

See also L<YAML::Type/regexp> of L<YAML::Types>

=head2 read_yaml

    my $yaml = read_yaml($yaml_file);

Read YAML file

=head2 slurp

    my $data = slurp($file, %args);
    my $data = slurp($file, { %args });
    slurp($file, { buffer => \my $data });
    my $data = slurp($file, { binmode => ":raw:utf8" });

Reads file $filename into a scalar

    my $data = slurp($file, { binmode => ":unix" });

Reads file in fast, unbuffered, raw mode

    my $data = slurp($file, { binmode => ":unix:encoding(UTF-8)" });

Reads file with UTF-8 encoding

By default it returns this scalar. Can optionally take these named arguments:

=over 4

=item binmode

Set the layers to read the file with. The default will be something sensible on your platform

=item block_size

Set the buffered block size in bytes, default to 1048576 bytes (1 MiB)

=item buffer

Pass a reference to a scalar to read the file into, instead of returning it by value.
This has performance benefits

=back

See also L</spew> to writing data to file

=head2 spew

    spew($file, $data, %args);
    spew($file, $data, { %args });
    spew($file, \$data, { %args });
    spew($file, \@data, { %args });
    spew($file, $data, { binmode => ":raw:utf8" });

Writes data to a file atomically. The only argument is C<binmode>, which is passed to
C<binmode()> on the handle used for writing.

Can optionally take these named arguments:

=over 4

=item append

This argument is a boolean option, defaulted to false (C<0>).
Setting this argument to true (C<1>) will cause the data to be be written at the end of the current file.
Internally this sets the sysopen mode flag C<O_APPEND>

=item binmode

Set the layers to write the file with. The default will be something sensible on your platform

=item locked

This argument is a boolean option, defaulted to false (C<0>).
Setting this argument to true (C<1>) will ensure an that existing file will not be overwritten

=item mode

This numeric argument sets the default mode of opening files to write.
By default this argument to C<(O_WRONLY | O_CREAT)>.
Please DO NOT set this argument unless really necessary!

lib/App/DistSync/Util.pm  view on Meta::CPAN

    }
    local $_;
    while (<$fh>){
        chomp;
        next if /^\s*#/;
        my($file, $args);

        if ($skipflag && $_ =~ /^\s*\!\!perl\/regexp\s*/i) { # Working in SkipMode
            #s/\r//;
            #$_ =~ qr{^\s*\!\!perl\/regexp\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$};
            #$args = $3;
            #my $file = $2;
            #if ( defined($1) ) {
            #    $file = $1;
            #    $file =~ s/\\(['\\])/$1/g;
            #}
            unless (($file, $args) = /^'(\\[\\']|.+)+'\s*(.*)/) {
                ($file, $args) = /^(^\s*\!\!perl\/regexp\s*\S+)\s*(.*)/;
            }
        } else {
            # filename may contain spaces if enclosed in ''
            # (in which case, \\ and \' are escapes)
            if (($file, $args) = /^'(\\[\\']|.+)+'\s*(.*)/) {
                $file =~ s/\\([\\'])/$1/g;
            } else {
                ($file, $args) = /^(\S+)\s*(.*)/;
            }
        }
        next unless $file;
        $read->{$file} = [defined $args ? split(/\s+/,$args) : ""];
    }
    close $fh;
    return $read;
}
sub manifind {
    my $dir = shift;
    carp("Can't specified directory") && return {} unless defined($dir) && -e $dir;

    my $found = {};
    my $base = File::Spec->canonpath($dir);
    #my ($volume,$sdirs,$sfile) = File::Spec->splitpath( $base );

    my $wanted = sub {
        my $path = File::Spec->canonpath($_);
        my $name = File::Spec->abs2rel( $path, $base );
        my $fdir = File::Spec->canonpath($File::Find::dir);
        return if -d $_;

        my $key = join("/", File::Spec->splitdir(File::Spec->catfile($name)));
        $found->{$key} = {
                mtime   => (stat($_))[9] || 0,
                size    => (-s $_) || 0,
                dir     => $fdir,
                path    => $path,
                file    => File::Spec->abs2rel( $path, $fdir ),
            };
    };

    # We have to use "$File::Find::dir/$_" in preprocess, because
    # $File::Find::name is unavailable.
    # Also, it's okay to use / here, because MANIFEST files use Unix-style
    # paths.
    find({
            wanted      => $wanted,
            no_chdir    => 1,
        }, $dir);

    return $found;
}
sub maniwrite {
    my $file = shift;
    my $mani = shift;
    carp("Can't specified file") && return 0 unless defined($file);
    carp("Can't specified manifest-hash") && return 0 unless defined($mani) && ref($mani) eq 'HASH';
    my $file_bak = $file.".bak";

    rename $file, $file_bak;
    my $fh;

    unless (open $fh, ">", $file){
        printf STDERR "Can't open file \"%s\": %s\n", $file, $!;
        rename $file_bak, $file;
        return 0;
    }

    # Stamp
    print  $fh "###########################################\n";
    printf $fh "# File created at %s\n", scalar(localtime(time()));
    print  $fh "# Please, do NOT edit this file directly!!\n";
    print  $fh "###########################################\n\n";

    foreach my $f (sort { lc $a cmp lc $b } keys %$mani) {
        my $d = $mani->{$f};
        my $text = sprintf("%s\t%s\t%s",
                $d->{mtime} || 0,
                $d->{size} || 0,
                $d->{mtime} ? scalar(localtime($d->{mtime})) : 'UNKNOWN',
            );
        my $tabs = (8 - (length($f)+1)/8);
        $tabs = 1 if $tabs < 1;
        $tabs = 0 unless $text;
        if ($f =~ /\s/) {
            $f =~ s/([\\'])/\\$1/g;
            $f = "'$f'";
        }
        print $fh $f, "\t" x $tabs, $text, "\n";
    }
    close $fh;

    unlink $file_bak;

    return 1;
}

1;

__END__