root/trunk/build/Build.pm

Revision 3886, 30.8 kB (checked in by fumiakiy, 5 months ago)

Merged fringale down to trunk. "svn merge -r 3460:3877 http://code.sixapart.com/svn/movabletype/branches/fringale ."
  • Property svn:keywords set to Id
Line 
1# Movable Type (r) Open Source (C) 2001-2009 Six Apart, Ltd.
2# This program is distributed under the terms of the
3# GNU General Public License, version 2.
4#
5# $Id$
6
7package Build;
8our $VERSION = '0.08';
9
10=head1 NAME
11
12Build - Movable Type build functionality
13
14=head1 SYNOPSIS
15
16 cd $MT_DIR
17 svn update
18 perl build/exportmt.pl --help
19 perl build/exportmt.pl --debug
20    # --alpha=1
21    # --beta=42
22    # --local
23    # --make
24    # --plugin=Foo --plugin=Bar
25    # --prod
26    # --qa
27    # --stage
28
29=head1 DESCRIPTION
30
31A C<Build> object contains the internal routines needed to build
32Movable Type distributions in multiple languages.
33
34=cut
35
36use strict;
37use warnings;
38use Cwd;
39use File::Basename;
40use File::Copy;
41use File::Path;
42use File::Spec;
43use Getopt::Long;
44use IO::File;
45use Sys::Hostname;
46
47sub new {
48    my $class = shift;
49    my $self = {};
50    bless $self, $class;
51    return $self;
52}
53
54sub get_options {
55    my $self = shift;
56    my %o = (
57      'agent=s'         => '',  # Constructed at run-time.
58      'alpha=s'         => 0,  # Alpha build number.
59      'arch=s@'         => undef,  # Constructed below.
60      'beta=s'          => 0,  # Beta build number.
61      'rc=s'            => 0,  # Release candidate build number.
62      'cleanup!'        => 1,  # Remove the exported directory after deployment.
63      'date!'           => 1,  # Toggle date stamping.
64      'debug'           => 0,  # Turn on/off the actual system calls.
65      'deploy:s'        => '',
66      'deploy-uri=s'    => '',
67      'build!'          => 1,  # Build distribution files?
68      'email-bcc:s'     => undef,
69      'email-body=s'    => '',  # Constructed at run-time.
70      'email-cc:s'      => undef,
71      'email-from=s'    => ( $ENV{USER} || $ENV{USERNAME} ),
72      'email-host=s'    => 'localhost',
73      'email-subject=s' => '',  # Constructed at run-time.
74      'export!'         => 1,  # To export or not to export. That is the question.
75      'export-dir=s'    => '',  # Constructed at run-time.
76      'footer=s'        => "<br/><b>SOFTWARE IS PROVIDED FOR TESTING ONLY - NOT FOR PRODUCTION USE.</b>\n",
77      'footer-tmpl=s'   => 'tmpl/cms/include/copyright.tmpl',
78      'help|h'          => 0,  # Show the program usage.
79      'license=s'       => undef,
80      'http-user=s'     => undef,
81      'http-pass=s'     => undef,
82      'ldap'            => 0,  # Use LDAP (and don't initialize the database).
83      'lang=s'          => $ENV{BUILD_LANGUAGE} || 'en_US',  # de,es,en_US,fr,ja,nl
84      'language=s@'     => undef,  # Constructed below.
85      'local'           => 0,  # Command-line --option alias
86      'make'            => 0,  # Command-line --option alias for simple legacy `make`
87      'notify:s'        => undef,  # Send email notification on completion.
88      'pack=s'          => undef,  # Constructed at run-time.
89      'plugin=s@'       => undef,  # Plugin list
90      'plugin-uri=s'    => 'http://code.sixapart.com/svn/mtplugins/trunk',
91      'prod'            => 0,  # Command-line --option alias
92      'prod-dir=s'      => 'Production_Builds',
93      'qa'              => 0,  # Command-line --option alias
94      'repo=s'          => 'trunk',  # Reset at runtime depending on branch,tag.
95      'repo-uri=s'      => '',
96      'rev!'            => 1,  # Toggle revision stamping.
97      'revision=s'      => undef,  # Constructed at run-time.
98      'stage'           => 0,  # Command-line --option alias
99      'stage-dir=s'     => '',
100      'stage-uri=s'     => '',
101      'short-lang=s'    => '',  # Constructed at run-time.
102      'stamp=s'         => $ENV{BUILD_VERSION_ID},
103      'symlink!'        => 1,  # Make build symlinks when staging.
104      'verbose!'        => 1,  # Express (the default) or suppress run output.
105      @_,
106    );
107
108    # Map all literal string values to scalar references because
109    # Getopt::Long wants it that way.
110    while( my( $key, $val ) = each %o ) {
111       $o{$key} = \$val unless ref $val;
112    }
113
114    GetOptions( %o );  # Get the command-line options.
115
116    # "Un-map" the references so we don't have to say, ${$self->{'foo'}}.
117    while( my( $key, $val ) = each %o ) {
118        $self->{$key} = $$val
119            if ref($val) eq 'SCALAR' || ref($val) eq 'REF';
120    }
121
122    # Make sure we have an archive file type list.
123    $self->{'arch=s@'} ||= [qw( .tar.gz .zip )];
124    # Make the plugins an empty list unless defined.
125    $self->{'plugin=s@'} ||= [];
126    # Construct the list of languages to build.
127    $self->{'lang=s'} = 'de,en_US,es,fr,ja,nl'
128        if lc( $self->{'lang=s'} ) eq 'all';
129    push @{ $self->{'language=s@'} }, split /,/, $self->{'lang=s'};
130}
131
132sub setup {
133    my $self = shift;
134    my %args = @_;
135
136    my $prereq = 'ExtUtils::Install 1.37_02';
137    eval "use $prereq";
138    die( "ERROR: Can't handle @{ $self->{'plugin=s@'} } plugin installation: $prereq needed." )
139        if $@ && @{ $self->{'plugin=s@'} };
140
141    # Do we have SSL support?
142    $prereq = 'Crypt::SSLeay';
143    eval "require $prereq;";
144    warn( "WARNING: $prereq not found. Can't use SSL.\n" ) if $@;
145
146    # Replace the current language if given one as an argument.
147    $self->{'lang=s'} = $args{language} if $args{language};
148    # Strip the dialect portion of the language code (ab_CD into ab).
149    ($self->{'short-lang=s'} = $self->{'lang=s'}) =~ s/([a-z]{2})_[A-Z]{2}$/$1/o;
150
151    $self->{'pack=s'} ||= 'MTOS';
152    $ENV{BUILD_PACKAGE}  = $self->{'pack=s'};
153    $ENV{BUILD_LANGUAGE} = $self->{'lang=s'};
154
155    # Handle option aliases.
156    if( $self->{'prod'} or $self->{'alpha=s'} or $self->{'beta=s'} or $self->{'rc=s'} ) {
157        $self->{'symlink!'} = 0;
158    }
159    if( $self->{'make'} ) {
160        $self->{'build!'} = 0;
161        $self->{'export!'} = 0;
162    }
163    if( $self->{'local'} ) {
164        $self->{'export!'} = 0;
165    }
166    if( $self->{'stage'} ) {
167        $self->{'deploy:s'} = $self->{'stage-dir=s'};
168    }
169
170    # Grab our repository revision.
171    $self->{'revision=s'} = repo_rev();
172    # Figure out what repository to use.
173    $self->set_repo();
174
175    # Create the build-stamp if one is not already defined.
176    if( !$self->{'stamp=s'} || $args{language} ) {
177        # Read-in the configuration variables for substitution.
178        my $config = $self->read_conf( "build/mt-dists/default.mk", "build/mt-dists/$self->{'pack=s'}.mk" );
179        $self->{'license=s'} ||= $config->{LICENSE};
180        my @stamp = ();
181        if ($self->{'stamp=s'}) {
182            push @stamp, $self->{'stamp=s'};
183        } else {
184            push @stamp, $config->{PRODUCT_VERSION} . (
185                $self->{'alpha=s'} ? "a$self->{'alpha=s'}"
186              : $self->{'beta=s'}  ? "b$self->{'beta=s'}"
187              : $self->{'rc=s'}    ? "rc$self->{'rc=s'}"
188              : '' );
189        }
190        # Add repo, date and ldap to the stamp if we are not production.
191        unless( $self->{'prod'} ) {
192            push @stamp, $self->{'short-lang=s'};
193            if( $self->{'rev!'} ) {
194                push @stamp, lc( fileparse $self->{'repo=s'} );
195                push @stamp, $self->{'revision=s'};
196            }
197            push @stamp, sprintf(
198                '%04d%02d%02d', (localtime)[5]+1900, (localtime)[4]+1, (localtime)[3]
199            ) if $self->{'date!'};
200            # Add -ldap to distingush them from Melody Nelson builds.
201            push @stamp, 'ldap' if $self->{'ldap'};
202        }
203        $self->{'stamp=s'} = join '-', @stamp;
204        die( "ERROR: No stamp created. Cannot proceed.\n" )
205            unless $self->{'stamp=s'};
206    }
207
208    # Set the BUILD_VERSION_ID, which has not been defined until now.
209    $ENV{BUILD_VERSION_ID} ||= $self->{'stamp=s'};
210
211    # Set the full name to use for the distribution (e.g. MT-3.3b1-fr-r12345-20061225).
212    $self->{'export-dir=s'} = "$self->{'pack=s'}-$self->{'stamp=s'}";
213    # Name the exported directory (and archive) with the language.
214    $self->{'export-dir=s'} .= "-$self->{'short-lang=s'}" if $self->{'prod'};
215}
216
217sub make {
218    my $self = shift;
219    $self->verbose( 'Entered make()' );
220    return if $self->{'debug'};
221
222    if( !$self->{'debug'} && $self->{'export!'} ) {
223        chdir( $self->{'export-dir=s'} ) or
224            die( "ERROR: Can't cd to $self->{'export-dir=s'}: $!" );
225        $self->verbose( "Change to the $self->{'export-dir=s'} directory" );
226    }
227
228    if( $self->{'build!'} ) {
229        $self->verbose_command( sprintf(
230            '%s build/mt-dists/make-dists --package=%s --language=%s --stamp=%s %s --license=%s',
231            $^X,
232            $self->{'pack=s'},
233            $self->{'lang=s'},
234            $self->{'export-dir=s'},
235            ($self->{'verbose!'} ? '--silent' : ''),
236            $self->{'license=s'} || '',
237        ));
238    }
239    else {
240        $self->verbose_command( 'make' );
241    }
242
243    if( !$self->{'debug'} && $self->{'export!'} ) {
244        chdir( '..' ) or die( "ERROR: Can't cd ..: $!" );
245        $self->verbose( 'Change back to the parent directory' );
246    }
247}
248
249sub cleanup {
250    my $self = shift;
251    $self->verbose( 'Entered cleanup()' );
252    return unless $self->{'cleanup!'};
253
254    my $build = $self->{'export-dir=s'};  # Less ugly.
255    if( !$self->{'debug'} && $self->{'export!'} ) {
256        # Move the build archives out of the soon-to-be-removed build directory.
257        for my $arch ( @{ $self->{'arch=s@'} } ) {
258            move( "$build/$build$arch", "$build$arch" )
259                or die( "ERROR: Can't move $build/$build$arch: $!" );
260        }
261
262        rmtree( $build ) or die( "ERROR: Can't rmtree clean-up $build: $!" );
263    }
264    $self->verbose( "Cleanup: Remove $build" );
265}
266
267sub create_distro_list {
268    my $self = shift;
269
270    my $distros = { path => [], url => [] };
271
272    my %seen = ();
273
274    for my $lang ( split( /\s*,\s*/, $self->{'lang=s'} ) ) {
275        for my $arch ( @{ $self->{'arch=s@'} } ) {
276            # The filename is the distribution name plus the archive extension.
277            my $filename = $self->{'export-dir=s'} . $arch;
278
279            # The distribution is the full export path and filename.
280            my $dist = File::Spec->catdir( $self->{'export-dir=s'}, $filename );
281
282            # Create lists of the distribution paths.
283            push @{ $distros->{path} }, $dist;
284
285            # Add to the URL list depending on where we are deploying.
286            if( $self->{'stage'} ) {
287                # Magically use the internal production folder if it exists.
288                my $loc = $self->{'prod'} && $self->{'prod-dir=s'} && $dist =~ /$self->{'prod-dir=s'}/
289                    ? sprintf( "%s/%s/%s/mt.cgi",
290                        $self->{'stage-uri=s'}, $self->{'prod-dir=s'}, $self->{'export-dir=s'} )
291                    : sprintf( "%s/%s/mt.cgi", $self->{'stage-uri=s'}, $self->{'export-dir=s'} );
292                push @{ $distros->{url} }, $loc unless $seen{$loc}++;
293            }
294            elsif( $self->{'deploy:s'} =~ /:/ ) {
295                my $loc = sprintf '%s/%s', $self->{'deploy-uri=s'}, $filename;
296                push @{ $distros->{url} }, $loc unless $seen{$loc}++;
297            }
298        }
299    }
300
301    return $distros;
302}
303
304sub deploy_distros {
305    my $self = shift;
306    my $distros = shift;
307
308    return unless $self->{'deploy:s'};
309
310    # If a colon is in the deployment string, use scp.
311    if( $self->{'deploy:s'} =~ /:/ ) {
312        $self->verbose_command( sprintf( '%s %s %s',
313            'scp',
314            join(' ', @{ $distros->{path} }),
315            $self->{'deploy:s'}
316        ) );
317    }
318    # Otherwise, copy the distribution file(s) to the destination.
319    else {
320        for my $dist ( @{ $distros->{path} } ) {
321            my $dest = '';
322
323            # Magically use the internal production folder if it exists.
324            if( $self->{'prod'} && $self->{'stage'} && $self->{'prod-dir=s'} &&
325                -e File::Spec->catdir( $self->{'stage-dir=s'}, $self->{'prod-dir=s'} )
326            ) {
327                $dest = File::Spec->catdir(
328                    $self->{'deploy:s'},
329                    $self->{'prod-dir=s'},
330                    scalar fileparse( $dist ),
331                );
332            }
333            else {
334                $dest = File::Spec->catdir(
335                    $self->{'deploy:s'},
336                    scalar fileparse( $dist ),
337                );
338            }
339
340            copy( $dist, $dest ) or die( "ERROR: Can't copy $dist to $dest: $!" )
341                unless $self->{'debug'};
342            $self->verbose( "Copy $dist to $dest" );
343
344            # Install the build if we are staging.
345            $self->stage_distro( $dest ) if $self->{'stage'};
346
347            # Update the build summary page.
348            $self->update_html( $dest );
349
350        }
351    }
352
353    # Make sure the deployed distros actually made it.
354    unless( $self->{'debug'} ) {
355        for( @{ $distros->{url} } ) {
356            die( "ERROR: $_ can't be resolved." )
357                unless $self->{'agent=s'}->head( $_ );
358        }
359    }
360}
361
362sub stage_distro {
363    my $self = shift;
364    my $dest = shift;
365
366    # We only stage tar.gz's.
367    return if $dest !~ /\.gz$/o;
368
369    die( "ERROR: Cannot stage '$dest': No such file or directory" )
370        unless $self->{'debug'} || -e $dest;
371
372    my $cwd = cwd();
373
374    my $prod = $self->{'prod'} && $self->{'stage'} && $self->{'prod-dir=s'} && -e File::Spec->catdir( $self->{'stage-dir=s'}, $self->{'prod-dir=s'} );
375
376    # Add the prod-dir to the staged directory if appropriate.
377    my $stage_root = $self->{'stage-dir=s'};
378    $stage_root = File::Spec->catdir( $self->{'stage-dir=s'}, $self->{'prod-dir=s'} )
379        if $prod;
380
381    chdir $stage_root or
382        die( "ERROR: Can't chdir to $stage_root $!" );
383    $self->verbose( "Change to staging root $stage_root" );
384
385    # Do we have a current symlink?
386    my $link = lc( fileparse $self->{'repo=s'} );
387    $link .= "-$self->{'short-lang=s'}";
388    $link .= '-ldap' if $self->{'ldap'};
389    my $current = '';
390    $current = readlink( $link ) if $self->{'symlink!'} and -e $link;
391    # Remove any trailing slash.
392    $current =~ s/\/$//;
393    # Database named the same as the distribution (but with _'s).
394    (my $current_db = $current) =~ s/[.-]/_/g;
395    $current_db = 'stage_' . $current_db;
396
397    # Set the stage_dir to the literal build directory name.
398    my $stage_dir = fileparse( $dest, @{ $self->{'arch=s@'} } );
399    # Reset the staging root directory.
400    $stage_root = File::Spec->catdir( $stage_root, $stage_dir );
401
402    # Remove any existing distro, with the same path name.
403    if( -d $stage_root ) {
404        rmtree( $stage_root ) or
405            die( "ERROR: Can't rmtree the old $stage_root $!" )
406            unless $self->{'debug'};
407        $self->verbose( "Remove: $stage_root" );
408    }
409
410    # Drop previous.
411    if( -d $current ) {
412        rmtree( $current ) or
413            warn( "WARNING: Can't rmtree previous '$current': $!" )
414            unless $self->{'debug'};
415        for my $arch ( @{ $self->{'arch=s@'} } ) {
416            unlink( "$current$arch" ) or
417                warn( "WARNING: Can't unlink '$current$arch': $!\n" )
418                unless $self->{'debug'} or ("$current$arch" eq $dest);
419        }
420    }
421
422    # Un-tar the distribution.
423    my $tar;
424    unless( $self->{'debug'} ) {
425        $self->verbose( "Extract: $dest..." );
426        # Temporarily switching to using tar utility for this
427        # since Archive::Tar is croaking on one of our files.
428        `tar xf $dest`;
429        # $tar = Archive::Tar->new( $dest );
430        # $tar->extract();
431    }
432    $self->verbose( "Extract: $dest" );
433
434    # Change to the distribution directory.
435    chdir( $stage_root ) or die( "ERROR: Can't chdir $stage_root $!" )
436        unless $self->{'debug'};
437    $self->verbose( "Change to $stage_root" );
438
439    # Make sure there is a user-style so we don't barf unneccessarily into the error_log.
440    open STYLE, "> user_styles.css" or
441        die( "ERROR: Can't touch user_styles.css $@" );
442    close STYLE;
443
444    # Our database is named the same as the distribution (but with _'s) except for LDAP.
445    (my $db = $stage_dir) =~ s/[.-]/_/g;
446    # Reset the db to have the same name, if we are LDAP.
447    $db = 'ldap' if $self->{'ldap'};
448    # Append the handy staging build flag.
449    $db = 'stage_' . $db;
450
451    # Set the staging URL to a real location now.
452    my $url = sprintf '%s/%s/', $self->{'stage-uri=s'},
453        ($prod
454            ? File::Spec->catdir( $self->{'prod-dir=s'}, $stage_dir )
455            : $self->{'symlink!'}
456                ? $link
457                : $stage_dir
458        );
459
460    # Give unto us a shiny, new config file.
461    my $config = 'mt-config.cgi';
462    unless( $self->{'debug'} ) {
463        my $fh = IO::File->new( ">$config" );
464        print $fh <<CONFIG;
465CGIPath $url
466# DefaultSiteURL http://example.com/blogs/
467# DefaultSiteRoot /var/www/html/blogs/
468Database $db
469ObjectDriver DBI::mysql
470DBUser root
471DebugMode 2
472CONFIG
473        if( $self->{'ldap'} ) {
474            print $fh <<CONFIG;
475AuthenticationModule LDAP
476# AuthLDAPURL ldap://ldap.example.com/dc=example,dc=com
477CONFIG
478        }
479
480        $fh->close();
481    }
482    $self->verbose( "Write configuration to $config" );
483
484    # Create and initialize a new database.
485    unless( $self->{'ldap'} ) {
486        # Set up the database for this distribution.
487        $self->verbose( 'Initialize database.' );
488        # XXX Use DBI ASAP.
489        # Drop the previous database.
490        $self->verbose_command( "mysqladmin -f -u root drop $current_db" )
491            if $current;
492        # Drop a database of same name.
493        if( $db ) {
494            $self->verbose_command( "mysqladmin -f -u root drop $db" );
495            $self->verbose_command( "mysqladmin -u root create $db" );
496            # Run the upgrade tool.
497            $self->verbose_command( "$^X ./tools/upgrade --name Melody" );
498        }
499        else {
500            die "ERROR: No database to stage - very odd.";
501        }
502    }
503
504    # Change to the parent of the new stage directory.
505    chdir( '..' ) or die( "ERROR: Can't chdir to .." )
506        unless $self->{'debug'};
507    $self->verbose( 'Change back to staging root' );
508
509    # Now we re-link the stamped directory.
510    if( $self->{'symlink!'} ) {
511        unless( $self->{'debug'} ) {
512            print "Unlink $link\n";
513            # Drop current symlink.
514            unlink( $link ) or warn( "WARNING: Can't unlink '$link': $!" );
515            # Relink the staged directory.
516            symlink( "$stage_dir/", $link ) or
517                warn( "WARNING: Can't symlink $stage_dir/ to $link: $!" );
518        }
519        $self->verbose( "Symlink: $stage_dir/ to $link" );
520    }
521
522    unless( $self->{'debug'} or $self->{'symlink!'} ) {
523        # Make sure we can get to our symlink.
524        $url = sprintf "%s/%s/mt.cgi",
525            $self->{'stage-uri=s'}, $link;
526        die( "ERROR: Staging $url can't be resolved." )
527            unless $self->{'agent=s'}->head( $url );
528        # Make sure we can get to our archive file symlinks.
529        for my $arch ( @{ $self->{'arch=s@'} } ) {
530            $url = sprintf '%s/%s%s',
531                $self->{'stage-uri=s'}, $stage_dir, $arch;
532            die( "ERROR: Staging $url can't be resolved." )
533                unless $self->{'agent=s'}->head( $url );
534        }
535    } 
536
537    chdir( $cwd ) or die( "ERROR: Can't chdir back to $cwd: $!" );
538}
539
540sub update_html {
541    my $self = shift;
542    $self->verbose( 'Entered update_html()' );
543    my $dest = shift;
544
545    if( $self->{'symlink!'} &&
546        !$self->{'prod'} &&
547        !$self->{'ldap'} &&
548        ($self->{'stage'} || ($self->{'deploy:s'} eq $self->{'stage-dir=s'}))
549    ) {
550        my( $stage_dir, $suffix );
551        ($stage_dir, undef, $suffix) = fileparse( $dest, @{ $self->{'arch=s@'} } );
552        my $lang = $self->{'short-lang=s'};
553        my $branch = $self->{'repo=s'};
554        $branch =~ s!^(branches|tags)/!!;
555        my $revision = $self->{'revision=s'};
556        $revision =~ s!^r!!;
557
558        my $old_html = File::Spec->catdir( $self->{'stage-dir=s'}, 'build.html' );
559
560        unless( -e $old_html ) {
561            warn "WARNING: Staging HTML file, $old_html, does not exist.\n";
562            return;
563        }
564        unless( -e $stage_dir ) {
565            warn "WARNING: Distribution file, $dest, does not exist.\n";
566            return;
567        }
568
569        my $id = lc( fileparse $self->{'repo=s'} ) . "-$lang$suffix";
570        $self->verbose( "Update: $old_html with $id for $dest" );
571
572        my %set;
573        unless( $self->{'debug'} ) {
574            warn "WARNING: $old_html does not exist" unless -e $old_html;
575            my $new_html = "$old_html.new";
576            my $old_fh = IO::File->new( '< ' . $old_html );
577            my $new_fh = IO::File->new( '> ' . $new_html );
578
579            while( my $line = <$old_fh> ) {
580                # build replacement
581                if( $line =~ m!^(\s*).*?/\*\s*(build|branch):\s*(\S+?)\s*\*/! ) {
582                    my $spacer = $1;
583                    my $type = $2;
584                    my $val = $3;
585                    if ($type eq 'build') {
586                        if ($val eq $id) {
587                            $self->verbose( "Matched $type: id=$id" );
588                            $set{$type} = 1;
589                            $line = sprintf qq|$spacer'$id': '%s/%s%s', /* build: $id */\n|,
590                                $self->{'stage-uri=s'},
591                                $stage_dir, $suffix;
592                        }
593                    } elsif ($branch && ($type eq 'branch')) {
594                        if ($val eq $branch) {
595                            $self->verbose( "Matched $type: branch=$branch" );
596                            $set{$type} = 1;
597                            $line = sprintf qq|$spacer'$branch': '$revision', /* branch: $branch */\n|;
598                        }
599                    }
600                }
601                if ($line =~ m!^(\s*)/\*\s*new-(build|branch)\s*\*/!) {
602                    # create a new release
603                    my $spacer = $1;
604                    my $type = $2;
605                    unless ($set{$type}) {
606                        if ($type eq 'build') {
607                            $set{$type} = 1;
608                            $self->verbose( "Writing new build: id=$id" );
609                            my $new_line = sprintf qq|$spacer'$id': '%s/%s%s', /* build: $id */\n|,
610                                $self->{'stage-uri=s'},
611                                $stage_dir, $suffix;
612                            $line = $new_line . $line;
613                        } elsif ($branch && ($type eq 'branch')) {
614                            $set{$type} = 1;
615                            $self->verbose( "Writing new branch: branch=$branch" );
616                            my $new_line = sprintf qq|$spacer'$branch': '$revision', /* branch: $branch */\n|;
617                            $line = $new_line . $line;
618                        }
619                    }
620                }
621
622                print $new_fh $line;
623            }
624
625            $old_fh->close;
626            $new_fh->close;
627            move( $new_html, $old_html ) or
628                die( "ERROR: Can't move $new_html, $old_html: $!" );
629            $self->verbose( "Move: $new_html to $old_html" );
630        }
631    }
632}
633
634sub remove_copy {
635    my $self = shift;
636    if( -d $self->{'export-dir=s'} ) {
637        $self->verbose( "Remove existing export: $self->{'export-dir=s'}" );
638        rmtree( $self->{'export-dir=s'} ) or
639            die( "ERROR: Can't rmtree existing export $self->{'export-dir=s'}: $!" )
640            unless $self->{'debug'};
641    }
642}
643
644sub repo_rev {
645    my $revision = qx{ svn info | grep 'Last Changed Rev' };
646    chomp $revision;
647    $revision =~ s/^Last Changed Rev: (\d+)$/r$1/o;
648    die( "ERROR: $revision" ) if $revision =~ /is not a working copy/;
649    return $revision;
650}
651
652sub set_repo {
653    my $self = shift;
654
655    # Grab our repository from the environment.
656    $self->{'repo-uri=s'} = qx{ svn info | grep URL };
657    chomp $self->{'repo-uri=s'};
658    $self->{'repo-uri=s'} =~ s/^URL: (.+)$/$1/o;
659
660    if( $self->{'repo-uri=s'} =~ /http.+?(branches|tags)\/([0-9A-Za-z_.-]+)/ ) {
661        # The repo is embedded in the repo uri.
662        my( $key, $val ) = ( $1, $2 );
663        $self->{'repo=s'} = join '/', $key, $val;
664    }
665
666    # Make sure that the repository actually exists.
667    if( !$self->{'debug'} && $self->{'export!'} ) {
668        require LWP::UserAgent;
669        $self->{'agent=s'} = LWP::UserAgent->new;
670        my $request = HTTP::Request->new( HEAD => $self->{'repo-uri=s'} );
671        $request->authorization_basic( $self->{'http-user=s'}, $self->{'http-pass=s'} )
672            if $self->{'http-user=s'} && $self->{'http-pass=s'};
673        my $response = $self->{'agent=s'}->request( $request );
674        die( "ERROR: The repoository '$self->{'repo-uri=s'}' can't be resolved." )
675            unless $response->is_success;
676    }
677}
678
679sub export {
680    my $self = shift;
681    return unless $self->{'export!'};
682    # NOTE Subversion auto-creates the export directory.
683    $self->verbose_command( sprintf( 'svn export --quiet %s %s',
684        $self->{'repo-uri=s'}, $self->{'export-dir=s'}
685    ));
686}
687
688sub plugin_export {
689    my $self = shift;
690    return unless $self->{'plugin=s@'};
691
692    # Change to the export directory, if we are exporting.
693    chdir( $self->{'export-dir=s'} ) or
694        die( "ERROR: Can't cd to $self->{'export-dir=s'}: $!" )
695        if !$self->{debug} && $self->{'export!'};
696
697    # Export the plugins.
698    for my $plugin ( @{ $self->{'plugin=s@'} } ) {
699        my $uri = "$self->{'plugin-uri=s'}/$plugin";
700        my $path = "plugins/$plugin";
701        $self->verbose_command(
702            sprintf( 'svn export --quiet %s %s', $uri, $path )
703        );
704        die "ERROR: Plugin not exported: $uri"
705            unless $self->{debug} || -d $path;
706
707        # Handle the plugin subdirectory.
708        $path = 'plugins';
709        my $subdir = "plugins/$plugin/$path";
710        if( -d $subdir && !$self->{debug} ) {
711            $self->dirmove( $subdir, $path ) or
712                die( "Can't move $subdir to $path: $!" );
713            $self->verbose( "Moved $subdir to $path" );
714        }
715        # Handle the mt-static subdirectory.
716        $path = "mt-static/plugins";
717        $subdir = "plugins/$plugin/$path";
718        if( -d $subdir && !$self->{debug} ) {
719            $self->dirmove( $subdir, $path ) or
720                die( "Can't move directory $subdir to $path $!" );
721            $self->verbose( "Moved $subdir to $path" );
722        }
723
724        $path = "plugins/$plugin";
725        rmtree( $path ) or die( "Can't rmtree() $path: $!" )
726            unless $self->{debug};
727        $self->verbose( "Removed $path" );
728    }
729
730    chdir( '..' ) or die( "ERROR: Can't cd ..: $!" )
731        if !$self->{debug} && $self->{'export!'};
732}
733
734sub dirmove {
735    my $self = shift;
736    my @paths = @_;
737    my $dest = pop @paths;
738    for my $path ( @paths ) {
739#        $self->verbose( "Moving $path to $dest..." );
740        eval{ install({ $path => $dest }) };
741    }
742    return 1;
743}
744
745sub verbose_command {
746    my $self = shift;
747    my $command = shift;
748    $self->verbose( "Execute: $command" );
749    system $command unless $self->{'debug'};
750
751    if( $? == -1 ) {
752        die( "ERROR: Failed to execute: $!" );
753    }
754    elsif( $? & 127 ) {
755        die sprintf( "ERROR: Child died with signal %d, with%s coredump\n",
756            ( $? & 127 ), ( $? & 128 ? '' : 'out' )
757        );
758    }
759    else {
760#        printf "Child exited with value %d\n", $? >> 8 if $self->{'verbose!'};
761    }
762
763    return $command;
764}
765
766sub notify {
767    my $self = shift;
768    my $distros = shift;
769
770    return unless $self->{'notify:s'};
771    $self->verbose( 'Entered notify()' );
772    return if $self->{'debug'};
773
774    $self->{'email-subject=s'} = sprintf '%s build: %s',
775        $self->{'pack=s'}, $self->{'stamp=s'};
776    $self->{'email-subject=s'} .=
777        $self->{'alpha=i'} ? ' - Alpha ' . $self->{'alpha=i'} :
778        $self->{'beta=i'}  ? ' - Beta '  . $self->{'beta=i'}  :
779        $self->{'prod'}    ? ' - Production'             :
780        $self->{'stage'}   ? ' - Staging'                :
781        $self->{'qa'}      ? ' - QA'                     : '';
782    # If an email-cc exists, add a comma in front of the QA address.
783    # $self->{'email-cc:s'} .= ($self->{'email-cc:s'} ? ',' : '')
784    #     if $self->{'qa'};
785    # Show the deployed URL's.
786    $self->{'email-body=s'} = sprintf "File URL(s):\n%s\n\n",
787        join( "\n", @{ $distros->{url} } )
788        if $self->{'deploy:s'};
789    $self->{'email-body=s'} .= sprintf "Build file(s) located on %s\n%s",
790        hostname(), join( "\n", @{ $distros->{path} } )
791        if $self->{'qa'} or !$self->{'cleanup!'};
792
793    require Net::SMTP;
794    my $smtp = Net::SMTP->new(
795        $self->{'email-host=s'},
796        Debug => $self->{'debug'},
797    );
798
799    $smtp->mail( $self->{'email-from=s'} );
800    $smtp->to( $self->{'notify:s'} );
801    $smtp->cc( $self->{'email-cc:s'} ) if $self->{'email-cc:s'};
802    $smtp->bcc( $self->{'email-bcc:s'} ) if $self->{'email-bcc:s'};
803
804    $smtp->data();
805    $smtp->datasend( "To: $self->{'notify:s'}\n" );
806    $smtp->datasend( "Cc: $self->{'email-cc:s'}\n" ) if $self->{'email-cc:s'};
807    $smtp->datasend( "Subject: $self->{'email-subject=s'}\n" );
808    $smtp->datasend( "\n" );
809    $smtp->datasend( "$self->{'email-body=s'}\n" );
810    $smtp->dataend();
811
812    $smtp->quit;
813
814    $self->verbose( "Email sent to $self->{'notify:s'}" );
815}
816
817sub read_conf {
818    my $self = shift;
819    my @files = @_;
820    my $config = {};
821
822    for my $file ( @files ) {
823        next unless -e $file;
824        print "Parse: config $file file...\n";
825        my $fh = IO::File->new( '< ' . $file );
826
827        while( <$fh> ) {
828            # Skip comment lines.
829            next if /^\s*#/;
830            # Skip blank lines.
831            next if /^\s*$/;
832            # Capture a configuration pair.
833            /^\s*(.*?)\s*=\s*(.*)\s*$/ or next;
834            my( $k, $v ) = ( $1, $2 );
835            $config->{$k} = $v;
836        }
837
838        $fh->close;
839    }
840
841    return $config;
842}
843
844sub inject_footer {
845    my $self = shift;
846
847    # Do not inject the non-production footer if we are running in
848    # debug mode, doing a (local) make or are building an alpha/beta
849    # version.
850    return if $self->{'debug'} || $self->{'make'} ||
851        ($self->{'prod'} && !($self->{'beta=s'} || $self->{'alpha=s'} || $self->{'rc=s'}));
852    $self->verbose( 'Entered inject_footer()' );
853    return if $self->{'prod'} || $self->{'debug'} || $self->{'make'};
854
855    my $file = $self->{'export!'}
856        ? File::Spec->catdir( $self->{'export-dir=s'}, $self->{'footer-tmpl=s'} )
857        : $self->{'footer-tmpl=s'};
858    die( "ERROR: File $file does not exist: $!" ) unless -e $file;
859
860    # Slurp-in the contents of the file.
861    local $/;
862    my $fh = IO::File->new( $file );
863    my $contents = <$fh>;
864    $fh->close();
865
866    return if $contents =~ m/\Q$self->{'footer=s'}\E/;
867
868    $contents =~ s/Reserved.\n/Reserved.\n$self->{'footer=s'}/;
869
870    # Rewrite the file with the injected footer.
871    $fh = IO::File->new( "> $file" );
872    print $fh $contents;
873    $fh->close();
874}
875
876sub verbose {
877    my $self = shift;
878    return unless $self->{'verbose!'};
879    print join( "\n", @_ ), "\n\n";
880}
881
882sub languages { return @{ shift->{'language=s@'} } }
883
884sub debug { return shift->{'debug'} }
885
886sub help { return shift->{'help|h'} }
887
888sub usage {
889    my $self = shift;
890    print <<'USAGE';
891
892 MT export build deployment notification automation.
893 Examples:
894
895 cd $MT_DIR
896 svn update
897 perl build/exportmt.pl --help
898 perl build/exportmt.pl --debug
899    # --alpha=1
900    # --beta=42
901    # --local
902    # --make
903    # --plugin=Foo --plugin=Foo
904    # --prod
905    # --qa
906    # --stage
907
908USAGE
909    exit;
910}
911
9121;
913__END__
Note: See TracBrowser for help on using the browser.