view release on metacpan or  search on metacpan

lib/File/TreeBuilder.pm  view on Meta::CPAN

use 5.008001;
use strict;
use warnings;
package File::TreeBuilder;
BEGIN {
  $File::TreeBuilder::VERSION = '0.02';
}
# ABSTRACT: Build simple trees of files and directories.

# --------------------------------------------------------------------
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(build_tree);

# --------------------------------------------------------------------
sub build_tree {
    my ($dir, $str) = @_;
    my $caller_pkg = (caller)[0];
    $str = q[] unless defined $str;
    my @lines = split /\n/, $str;
        # Remove blank lines and comments.
    @lines = grep ! /^\s*(?:#|$)/, @lines;
    my $err_str = q[];
    _build_tree($dir, $caller_pkg, \$err_str, @lines);
    return $err_str;
}

# --------------------------------------------------------------------
sub _build_tree {
    my ($dir, $caller_pkg, $err_str_ref, @lines) = @_;
    if (! defined $dir) {
        $$err_str_ref .= "Directory not defined.\n";
        return;
    }
    if ($dir eq '') {
        $$err_str_ref .= "\$dir is empty string.\n";
        return;
    }
    if (! -d $dir) {
        mkdir($dir) or do {
            $$err_str_ref .= "Couldn't create '$dir'.\n";
            return;
        }
    }
    return unless @lines;
        # Remove from the beginning of each line as many leading
        # spaces as there are on the first one.
    my ($leading_spaces) = $lines[0] =~ /^( +)/;
    my ($nb_leading_spaces) = length($leading_spaces || '');
    @lines = map { s/ {$nb_leading_spaces}//; $_ } @lines;
    my $i = 0;
    while ($i < @lines) {
        if ($lines[$i] =~ /^\./) {
            _build_file($dir, $caller_pkg, $err_str_ref, $lines[$i]);
            return unless $$err_str_ref eq q[];
            ++$i;
        }
        elsif ($lines[$i] =~ /^\//) {
            my ($to_eval) = $lines[$i] =~ / ^ \/ \s+ (.*) /x;
            my $sub_dir;
            eval "no strict; package $caller_pkg; (\$sub_dir) = ($to_eval)";
            ++$i, next unless defined $sub_dir;
            my @sub_lines;
            push @sub_lines, $lines[$i]
              while ++$i < @lines && substr($lines[$i], 0, 1) eq ' ';
            _build_tree("$dir/$sub_dir", $caller_pkg, $err_str_ref, @sub_lines);
        }
        else {
            ++$i;
        }
    }
}

# --------------------------------------------------------------------
sub _build_file {
    my ($dir, $caller_pkg, $err_str_ref, $line) = @_;
    my ($to_eval) = $line =~ / ^ \. \s+ (.*) /x;
    my ($fname, $contents);