Show make-release.pl syntax highlighted
#! /usr/bin/perl -w
# $Id: make-release.pl,v 1.5 2004/03/21 08:43:17 mschering Exp $
# Script for creating a distribution archive. Based on make-release.pl from
# jscalendar.
# Author: Mihai Bazon, http://dynarch.com/mishoo
# NO WARRANTIES WHATSOEVER. READ GNU LGPL.
# This file requires HTML::Mason; this module is used for automatic
# substitution of the version/release number as well as for selection of the
# changelog (at least in the file release-notes.html). It might not work
# without HTML::Mason.
use strict;
# use diagnostics;
use HTML::Mason;
use File::Find;
use XML::Parser;
use Data::Dumper;
my $verbosity = 1;
my $tmpdir = '/tmp';
my $config = parseXML("project-config.xml");
speak(3, Data::Dumper::Dumper($config));
my ($project, $version, $release, $basename);
$project = $config->{project}{ATTR}{title};
$version = $config->{project}{version}{DATA};
$release = $config->{project}{release}{DATA};
$basename = "$project-$version";
$basename .= "-$release" if ($release);
speak(1, "Project: $basename");
## create directory tree
my ($basedir);
{
# base directory
$basedir = "$tmpdir/$basename";
if (-d $basedir) {
speak(-1, "$basedir already exists, removing... >:-]\n");
system "rm -rf $basedir";
}
}
process_directory();
## make the ZIP file
chdir "$basedir/..";
speak(1, "Making ZIP file /tmp/$basename.zip");
system ("zip -r $basename.zip $basename > /dev/null");
system ("ls -la /tmp/$basename.zip");
## remove the basedir
system("rm -rf $basedir");
## back
#chdir $cwd;
### SUBROUTINES
# handle _one_ file
sub process_one_file {
my ($attr, $target) = @_;
$target =~ s/\/$//;
$target .= '/';
my $destination = $target.$attr->{REALNAME};
# copy file first
speak(1, " copying $attr->{REALNAME}");
system "cp $attr->{REALNAME} $destination";
my $masonize = $attr->{masonize} || '';
if ($masonize =~ /yes|on|1/i) {
speak(1, " > masonizing to $destination...");
my $args = $attr->{args} || '';
my @vars = split(/\s*,\s*/, $args);
my %args = ();
foreach my $i (@vars) {
$args{$i} = eval '$'.$i;
speak(1, " > argument: $i => $args{$i}");
}
my $outbuf;
my $interp = HTML::Mason::Interp->new ( comp_root => $target,
out_method => \$outbuf );
$interp->exec("/$attr->{REALNAME}", %args);
open (FILE, "> $destination");
print FILE $outbuf;
close (FILE);
}
}
# handle some files
sub process_files {
my ($files, $target) = @_;
# proceed with the explicitely required files first
my %options = ();
foreach my $i (@{$files}) {
$options{$i->{ATTR}{name}} = $i->{ATTR};
}
foreach my $i (@{$files}) {
my @expanded = glob "$i->{ATTR}{name}";
foreach my $file (@expanded) {
$i->{ATTR}{REALNAME} = $file;
if (defined $options{$file}) {
unless (defined $options{$file}->{PROCESSED}) {
speak(1, "EXPLICIT FILE: $file");
$options{$file}->{REALNAME} = $file;
process_one_file($options{$file}, $target);
$options{$file}->{PROCESSED} = 1;
}
} else {
speak(2, "GLOB: $file");
process_one_file($i->{ATTR}, $target);
$options{$file} = 2;
}
}
}
}
# handle _one_ directory
sub process_directory {
my ($dir, $path) = @_;
my $cwd = '..'; # ;-)
(defined $dir) || ($dir = '.');
(defined $path) || ($path = '');
speak(2, "DIR: $path$dir");
$dir =~ s/\/$//;
$dir .= '/';
unless (-d $dir) {
speak(-1, "DIRECTORY '$dir' NOT FOUND, SKIPPING");
return 0;
}
# go where we have stuff to do
chdir $dir;
my $target = $basedir;
($path =~ /\S/) && ($target .= "/$path");
($dir ne './') && ($target .= $dir);
speak(1, "*** Creating directory: $target");
mkdir $target;
unless (-f 'makefile.xml') {
speak(-1, "No makefile.xml in this directory");
chdir $cwd;
return 0;
}
my $config = parseXML("makefile.xml");
speak(3, Data::Dumper::Dumper($config));
my $tmp = $config->{files}{file};
if (defined $tmp) {
my $files;
if (ref($tmp) eq 'ARRAY') {
$files = $tmp;
} else {
$files = [ $tmp ];
}
process_files($files, $target);
}
$tmp = $config->{files}{dir};
if (defined $tmp) {
my $subdirs;
if (ref($tmp) eq 'ARRAY') {
$subdirs = $tmp;
} else {
$subdirs = [ $tmp ];
}
foreach my $i (@{$subdirs}) {
process_directory($i->{ATTR}{name}, $path.$dir);
}
}
# get back to our previous location
chdir $cwd;
}
# this does all the XML parsing shit we'll need for our little task
sub parseXML {
my ($filename) = @_;
my $rethash = {};
my @tagstack;
my $handler_start = sub {
my ($parser, $tag, @attrs) = @_;
my $current_tag = {};
$current_tag->{NAME} = $tag;
$current_tag->{DATA} = '';
push @tagstack, $current_tag;
if (scalar @attrs) {
my $attrs = {};
$current_tag->{ATTR} = $attrs;
while (scalar @attrs) {
my $name = shift @attrs;
my $value = shift @attrs;
$attrs->{$name} = $value;
}
}
};
my $handler_char = sub {
my ($parser, $data) = @_;
if ($data =~ /\S/) {
$tagstack[$#tagstack]->{DATA} .= $data;
}
};
my $handler_end = sub {
my $current_tag = pop @tagstack;
if (scalar @tagstack) {
my $tmp = $tagstack[$#tagstack]->{$current_tag->{NAME}};
if (defined $tmp) {
## better build an array, there are more elements with this tagname
if (ref($tmp) eq 'ARRAY') {
## oops, the ARRAY is already there, just add the new element
push @{$tmp}, $current_tag;
} else {
## create the array "in-place"
$tagstack[$#tagstack]->{$current_tag->{NAME}} = [ $tmp, $current_tag ];
}
} else {
$tagstack[$#tagstack]->{$current_tag->{NAME}} = $current_tag;
}
} else {
$rethash->{$current_tag->{NAME}} = $current_tag;
}
};
my $parser = new XML::Parser
( Handlers => { Start => $handler_start,
Char => $handler_char,
End => $handler_end } );
$parser->parsefile($filename);
return $rethash;
}
# print somethign according to the level of verbosity
# receives: verbosity_level and message
# prints message if verbosity_level >= $verbosity (global)
sub speak {
my ($v, $t) = @_;
if ($v < 0) {
print STDERR "\033[1;31m!! $t\033[0m\n";
} elsif ($verbosity >= $v) {
print $t, "\n";
}
}
See more files for this project here