view release on metacpan or  search on metacpan

lib/Template/App/ttree.pm  view on Meta::CPAN

    my(
        $destdir,
        $dryrun,
        $ignore,
        $n_mkdir,
        $n_skip,
        $recurse,
        $srcdir,
        $verbose,
    ) = @{ $running_conf }{ qw(
        destdir
        dryrun
        ignore
        n_mkdir
        n_skip
        recurse
        srcdir
        verbose
    )};

    my ($file, $path, $abspath, $check);
    my $target;
    local *DIR;

    my $absdir = join('/', $srcdir ? $srcdir : (), defined $dir ? $dir : ());
    $absdir ||= '.';

    opendir(DIR, $absdir) || do { $self->emit_warn("$absdir: $!\n"); return undef; };

    FILE: while (defined ($file = readdir(DIR))) {
        next if $file eq '.' || $file eq '..';
        $path = defined $dir ? "$dir/$file" : $file;
        $abspath = "$absdir/$file";

        next unless -e $abspath;

        # check against ignore list
        foreach $check (@$ignore) {
            if ($path =~ /$check/) {
                $self->emit_log( yellow(sprintf "  - %-32s (ignored, matches /$check/)\n", $path ) )
                    if $verbose > 1;
                $$n_skip++;
                next FILE;
            }
        }

        if (-d $abspath) {
            if ($recurse) {
                my ($uid, $gid, $mode);

                (undef, undef, $mode, undef, $uid, $gid, undef, undef,
                 undef, undef, undef, undef, undef)  = stat($abspath);

                # create target directory if required
                $target = "$destdir/$path";
                unless (-d $target || $dryrun) {
                    mkpath($target, $verbose, $mode) or
                        die red("Could not mkpath ($target): $!\n");

                    # commented out by abw on 2000/12/04 - seems to raise a warning?
                    # chown($uid, $gid, $target) || warn "chown($target): $!\n";

                    $$n_mkdir++;
                    $self->emit_log( green( sprintf "  + %-32s (created target directory)\n", $path ) )
                        if $verbose;
                }
                # recurse into directory
                $self->process_tree($path, $running_conf);
            }
            else {
                $$n_skip++;
                $self->emit_log( yellow(sprintf "  - %-32s (directory, not recursing)\n", $path ) )
                    if $verbose > 1;
            }
        }
        else {
            $self->process_file($path, $abspath, $running_conf);
        }
    }
    closedir(DIR);
}


#------------------------------------------------------------------------
# $self->process_file()
#
# File filtering and processing sub-routine called by $self->process_tree()
#------------------------------------------------------------------------

sub process_file {
    my $self = shift;
    my ($file, $absfile, $running_conf, %options) = @_;

    my(
        $accept,
        $all,
        $binmode,
        $config,
        $copy,
        $copy_dir,
        $depends,
        $destdir,
        $dryrun,
        $libdir,
        $link,
        $n_copy,
        $n_link,
        $n_proc,
        $n_skip,
        $n_unmod,
        $preserve,
        $replace,
        $srcdir,
        $suffix,
        $template,
        $verbose,
    ) = @{ $running_conf }{ qw(
        accept
        all
        binmode
        config

lib/Template/App/ttree.pm  view on Meta::CPAN

    if (not $copy_file and @$accept) {
        unless (grep { $filename =~ /$_/ } @$accept) {
            $self->emit_log( yellow( sprintf "  - %-32s (not accepted)\n", $file ) )
                if $verbose > 1;
            $$n_skip++;
            return;
        }
    }

    # stat the source file unconditionally, so we can preserve
    # mode and ownership
    ( undef, undef, $mode, undef, $uid, $gid, undef,
      undef, undef, $srctime, undef, undef, undef ) = stat($absfile);

    # test modification time of existing destination file
    if (! $all && ! $options{ force } && -f $dest) {
        $desttime = ( stat($dest) )[9];

        if (defined $depends and not $copy_file) {
            my $deptime  = $self->depend_time($file, $depends, $config, $libdir, $srcdir);
            if (defined $deptime && ($srctime < $deptime)) {
                $srctime = $deptime;
                $is_dep = 1;
            }
        }

        if ($desttime >= $srctime) {
            $self->emit_log( yellow( sprintf "  - %-32s (not modified)\n", $file ) )
                if $verbose > 1;
            $$n_unmod++;
            return;
        }
    }

    # check against link list
    if ($link_file) {
        unless ($dryrun) {
            if (link($absfile, $dest) == 1) {
                $copy_file = 0;
            }
            else {
                $self->emit_warn( red("Could not link ($absfile to $dest) : $!\n") );
            }
        }

        unless ($copy_file) {
            $$n_link++;
            $self->emit_log( green( sprintf "  > %-32s (linked, matches $check)\n", $file ) )
                if $verbose;
            return;
        }
    }

    # check against copy list
    if ($copy_file) {
        $$n_copy++;
        unless ($dryrun) {
            copy($absfile, $dest) or die red("Could not copy ($absfile to $dest) : $!\n");

            if ($preserve) {
                chown($uid, $gid, $dest) || $self->emit_warn( red("chown($dest): $!\n") );
                chmod($mode, $dest) || $self->emit_warn( red("chmod($dest): $!\n") );
            }
        }

        $self->emit_log( green( sprintf "  > %-32s (copied, matches $check)\n", $file ) )
            if $verbose;

        return;
    }

    $$n_proc++;

    if ($verbose) {
        $self->emit_log( green( sprintf "  + %-32s", $file) );
        $self->emit_log( green( sprintf " (changed suffix to $new_suffix)") ) if $new_suffix;
        $self->emit_log( "\n" );
    }

    # process file
    unless ($dryrun) {
        $template->process($file, $replace, $destfile,
            $binmode ? {binmode => $binmode} : {})
            || $self->emit_log(red("  ! "), $template->error(), "\n");

        if ($preserve) {
            chown($uid, $gid, $dest) || $self->emit_warn( red("chown($dest): $!\n") );
            chmod($mode, $dest) || $self->emit_warn( red("chmod($dest): $!\n") );
        }
    }
}


#------------------------------------------------------------------------
# $self->dependencies($file, $depends)
#
# Read the dependencies from $file, if defined, and merge in with
# those passed in as the hash array $depends, if defined.
#------------------------------------------------------------------------

sub dependencies {
    my $self = shift;
    my ($file, $depend) = @_;
    my %depends = ();

    if (defined $file) {
        my ($fh, $text, $line);
        open $fh, $file or die "Can't open $file, $!";
        local $/ = undef;
        $text = <$fh>;
        close($fh);
        $text =~ s[\\\n][]mg;

        foreach $line (split("\n", $text)) {
            next if $line =~ /^\s*(#|$)/;
            chomp $line;
            my ($file, @files) = quotewords('\s*:\s*', 0, $line);
            $file =~ s/^\s+//;
            @files = grep(defined, quotewords('(,|\s)\s*', 0, @files));
            $depends{$file} = \@files;
        }
    }

    if (defined $depend) {
        foreach my $key (keys %$depend) {
            $depends{$key} = [ quotewords(',', 0, $depend->{$key}) ];
        }
    }

    return \%depends;
}



#------------------------------------------------------------------------
# $self->depend_time($file, \%depends)
#
# Returns the mtime of the most recent in @files.
#------------------------------------------------------------------------

sub depend_time {
    my $self = shift;
    my ($file, $depends, $config, $libdir, $srcdir) = @_;
    my ($deps, $absfile, $modtime);
    my $maxtime = 0;
    my @pending = ($file);
    my @files;