view release on metacpan or  search on metacpan

Glade/Two/Generate.pm  view on Meta::CPAN

        die sprintf("error %s - can't close file '%s'", 
            $me, $proj_opt->{app}{logo});
    }
    
    unless ($proj_opt->{app}{logo} && -r $proj_opt->{app}{logo}) {
        $proj_opt->{app}{logo} = $proj_opt->{$type}{logo};
    }            

    $proj_opt->{doc}{directory} = $class->full_Path(
        $proj_opt->{doc}{directory} || 'Documentation', 
        $proj_opt->{glade}{directory});
    
    unless (-d $proj_opt->{doc}{directory}) { 
        # Source directory does not exist yet so create it
        $Glade_Perl->diag_print (2, "%s- Creating directory '%s' in %s", 
            $indent, $proj_opt->{doc}{directory}, $me);
        mkpath($proj_opt->{doc}{directory});
    }
    $proj_opt->{dist}{directory} = $class->full_Path(
        $proj_opt->{dist}{directory}, 
        $proj_opt->{glade}{directory});
    
    unless (-d $proj_opt->{dist}{directory}) { 
        # Source directory does not exist yet so create it
        $Glade_Perl->diag_print (2, "%s- Creating directory '%s' in %s", 
            $indent, $proj_opt->{dist}{directory}, $me);
        mkpath($proj_opt->{dist}{directory});
    }
    $proj_opt->{dist}{bin_directory} = $class->full_Path(
        ($proj_opt->{dist}{bin_directory} || './bin'),    
        $proj_opt->{dist}{directory},
        $proj_opt->{dist}{directory});
    unless (-d $proj_opt->{dist}{bin_directory}) { 
        # bin directory does not exist yet so create it
        $Glade_Perl->diag_print (2, "%s- Creating directory '%s' in %s",
            $indent, $proj_opt->{dist}{bin_directory}, $me);
        mkpath($proj_opt->{dist}{bin_directory});
    }
    $proj_opt->{dist}{bin} = $class->full_Path(
        ($proto->{glade}{project}{program_name} || 'run_'.$proj_opt->{app}{name}),
        $proj_opt->{dist}{bin_directory});

    $proj_opt->{dist}{test_directory} = $class->full_Path(
        ($proj_opt->{dist}{test_directory} || './t'),    
        $proj_opt->{dist}{directory},
        $proj_opt->{dist}{directory});
    unless (-d $proj_opt->{dist}{test_directory}) { 
        # bin directory does not exist yet so create it
        $Glade_Perl->diag_print (2, "%s- Creating directory '%s' in %s",
            $indent, $proj_opt->{dist}{test_directory}, $me);
        mkpath($proj_opt->{dist}{test_directory});
    }
    $proj_opt->{dist}{test_pl} = $class->full_Path(
        ($proj_opt->{dist}{test_pl} || './001_use_new.t'),    
        $proj_opt->{dist}{test_directory});

    if ($Glade_Perl->app->author) {
        $proj_opt->{app}{author} = $Glade_Perl->app->author;
    } else {
        my $host = hostname;
        my $pwuid = [(getpwuid($<))];
        my $user = $pwuid->[0];
        my $fullname = $pwuid->[6];
        my $hostname = [split(" ", $host)];
        $proj_opt->{app}{'author'} = "$fullname <$user\@$hostname->[0]>";
    }
    # Remove trailing spaces and ensure only one leading '#'
    $Glade_Perl->{app}{copying} =~ s/ *$//;
    if ($Glade_Perl->app->copying !~ /^#/) {
        $Glade_Perl->app->copying("#".$Glade_Perl->app->copying);
    }
    # escape any quotes
    $proj_opt->{app}{'author'} =~ s/\"/\\\"/g;
    $proj_opt->{app}{'author'} =~ s/\'/\\\'/g;

    $proj_opt->{app}{'version'}      ||= $Glade_Perl->app->version;
    $proj_opt->{app}{'date'}         ||= $Glade_Perl->app->date || $Glade_Perl->{$type}->start_time;
    $proj_opt->{app}{'copying'}      ||= $Glade_Perl->app->copying;
    $proj_opt->{app}{'description'}  ||= $Glade_Perl->app->description || 'No description';
    $proj_opt->{$type}->{xml}->{set_by}=($me);
    $proj_opt->{app}{'use_modules'}  ||= $Glade_Perl->app->use_modules;

    $proj_opt->{app}{use_modules} =
        [split (/\n/, ($proj_opt->{app}{use_modules} || ''))]
            unless ref $proj_opt->{app}{use_modules} eq 'ARRAY';
#print Dumper($proto->{app});
#print Dumper($Glade_Perl->{app});
#print Dumper($proj_opt->{app});
    # Now change to the <project><directory> so that we can find modules
    chdir $proj_opt->{glade}{directory};

    $Glade_Perl->diag_print(6, $proj_opt);
    return $proj_opt;
}

sub tree_from_string {
    my ($class, $xml, $encoding) = @_;
    my $me = (ref $class || $class)."->tree_from_string";
    my $xml_encoding;
    if ($xml =~ s/\<\?xml.*\s*encoding\=["'](.*?)['"]\s*\?\>\n*//) {
        $xml_encoding = $1;
    } else {
        $xml_encoding = $encoding;
    }
    print "    - Actual encoding found is '$xml_encoding'\n" 
        if $encoding ne $xml_encoding;
        
    my $tree = new XML::Parser(
        Style =>'Tree', 
        ProtocolEncoding => $xml_encoding,
        ErrorContext => 2)->parse($xml);
    return ($xml_encoding, $tree);
}

sub proto_from_tree {
    my ($class, $tree, $depth, $array, $hash, $special, $encoding) = @_;
    my $me = (ref $class||$class)."->proto_from_tree";

# FIXME make this general for all encodings
    if ($encoding && ($encoding eq 'ISO-8859-1')) {
        eval "use Unicode::String qw(utf8 latin1)";