root/branches/release-29/build/Build.pm @ 1308

Revision 1308, 30.8 kB (checked in by bsmith, 23 months ago)

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