| #! /usr/bin/perl -w |
| # $Id: make-release.pl,v 1.1 2004/02/06 10:10:07 ugo 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"; |
| } |
| } |