Navigation

← Previous Changeset
Next Changeset →

Changeset 702

Timestamp:

10/15/06 21:13:50 (2 years ago)

Author:

gboggs

Message:

- Added make dist and make me targets.
- Removed cruft (i.e. build/exportmt).
Updated the build system files to their latest incarnations.

Files:

branches/wheeljack/Makefile (modified) (2 diffs)
branches/wheeljack/build/Build.pm (modified) (2 diffs)
branches/wheeljack/build/exportmt (deleted)
branches/wheeljack/build/exportmt.pl (modified) (1 diff)
branches/wheeljack/build/mt-dists/make-dists (modified) (4 diffs)

Legend:

: Unmodified
: Added
: Removed
: Modified
: Copied
: Moved

branches/wheeljack/Makefile

r168	r702
84	84
85	85	$(local_js): mt-static/mt_%.js: mt-static/mt.js lib/MT/L10N/%.pm
86		build/mt-dists/make-js
	86	perl build/mt-dists/make-js
87	87
88	88	$(latin1_modules): %-iso-8859-1.pm: %.pm
…	…
148	148	t/47-i18n-ja.t t/48-cache.t t/49-tagsplit.t
149	149
	150	dist:
	151	perl build/exportmt.pl --local
	152
	153	me:
	154	perl build/exportmt.pl --make
	155
150	156	# tools-dist:
151	157	# (cd tools; perl -e 'use ExtUtils::Manifest qw(maniread manicopy); $$mani = maniread("MANIFEST"); manicopy($$mani, "mt-tools", "cp")'; tar czvf ../mt-tools.tar.gz mt-tools; zip -r ../mt-tools.zip mt-tools)

branches/wheeljack/build/Build.pm

r353	r702
1	1	# $Id$
2	2
	3	package Build;
	4	our $VERSION = '0.07';
	5
3	6	=head1 NAME
4	7
5		Build - Movable Type build functionality ~~via Module::Build~~
	8	Build - Movable Type build functionality
6	9
7	10	=head1 SYNOPSIS
8	11
9		# Build.PL
10		use lib 'build';
11		use Build;
12		my $build = Build->new( %args );
13		$build->preprocess();
14		$build->create_build_script();
15
16		# build/mt-build.PL
17		use lib 'build';
18		use Build;
19		my $build = Build->current;
20		for my $file ( @ARGV ) {
21		# Process the PL_files given as arguments.
22		}
	12	cd $MT_DIR
	13	svn update
	14	perl build/exportmt.pl --help
	15	perl build/exportmt.pl --debug
	16	# --alpha=1
	17	# --beta=42
	18	# --local
	19	# --make
	20	# --plugin=Foo --plugin=Bar
	21	# --prod
	22	# --qa
	23	# --stage
23	24
24	25	=head1 DESCRIPTION
25	26
26		A C<Build> object contains all the internal routines needed to build
27		Movable Type distributions.
	27	A C<Build> object contains the internal routines needed to build
	28	Movable Type distributions in multiple languages.
	29
	30	Please see the full documentation at:
	31	https://intranet.sixapart.com/wiki/index.php/Movable_Type:MT_Export-Deploy
28	32
29	33	=cut
30	34
31		~~package Build;~~
32		~~our $VERSION = '0.04';~~
33		~~use base qw( Module::Build );~~
34	35	use strict;
35	36	use warnings;
36	37	use Archive::Tar;
37		use Archive::Zip;
38		use Carp;
	38	use Cwd;
	39	use ExtUtils::Install 1.37_02;
	40	use File::Basename;
	41	use File::Copy;
	42	use File::Path;
	43	use File::Spec;
	44	use Getopt::Long;
39	45	use IO::File;
40		use File::Basename;
41		use File::Copy 'copy';
42		use File::Path;
43		use File::Slurp;
44		use Text::Iconv;
45
46		=head2 METHODS
47
48		=cut
49
50		sub languages { return qw( de es fr ja nl en_US ) }
51
52		=head2 languages()
53
54		my @languages = $build->languages();
55
56		Accessor routine to get the list of supported languages.
57
58		=cut
59
60		sub preprocess {
61		my $self = shift;
62
63		# Retrieve the build arguments or set to defaults.
64		my $language = $self->args( 'language' ) \|\| 'en_US';
65		my $package = $self->args( 'package' ) \|\| 'MT';
66
67		# Read-in the configuration variables for substitution.
68		my $config = read_conf(
69		'build/mt-dists/default.mk',
70		"build/mt-dists/$language.mk",
71		"build/mt-dists/$package.mk",
	46	use LWP::UserAgent;
	47	use Net::SMTP;
	48	use Sys::Hostname;
	49
	50	sub new {
	51	my $class = shift;
	52	my $self = {};
	53	bless $self, $class;
	54	return $self;
	55	}
	56
	57	sub 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	'cleanup!' => 1, # Remove the exported directory after deployment.
	65	'date!' => 1, # Toggle date stamping.
	66	'debug' => 0, # Turn on/off the actual system calls.
	67	'deploy:s' => '', #($ENV{USER}\|\|$ENV{USERNAME}).'@rongo:/usr/local/cifs/intranet/mt-interest/',
	68	'deploy-uri=s' => 'https://intranet.sixapart.com/mt-interest',
	69	'build!' => 1, # Build distribution files?
	70	'email-bcc:s' => undef,
	71	'email-body=s' => '', # Constructed at run-time.
	72	'email-cc:s' => undef,
	73	'email-from=s' => ( $ENV{USER} \|\| $ENV{USERNAME} ) .'@sixapart.com',
	74	'email-host=s' => 'mail.sixapart.com',
	75	'email-subject=s' => '', # Constructed at run-time.
	76	'export!' => 1, # To export or not to export. That is the question.
	77	'export-dir=s' => '', # Constructed at run-time.
	78	'footer=s' => "<br/><b>SOFTWARE IS PROVIDED FOR TESTING ONLY - NOT FOR PRODUCTION USE.</b>\n",
	79	'footer-tmpl=s' => 'tmpl/cms/footer.tmpl',
	80	'help\|h' => 0, # Show the program usage.
	81	'http-user=s' => undef,
	82	'http-pass=s' => undef,
	83	'ldap' => 0, # Use LDAP (and don't initialize the database).
	84	'lang=s' => $ENV{BUILD_LANGUAGE} \|\| 'en_US', # de,es,en_US,fr,ja,nl
	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' => '', #'https://intranet.sixapart.com/repos/eng',
	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' => '/var/www/html/mt-stage',
	100	'stage-uri=s' => 'http://mt.sixapart.com',
	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	@_,
72	106	);
73		# Add the build arguments to the config.
74		$config->{BUILD_LANGUAGE} = $language;
75		$config->{BUILD_PACKAGE} = $package;
76
77		# Add the configuration items to the build notes.
78		$self->notes( config => $config );
79		$self->notes( language => $language );
80		$self->notes( package => $package );
81
82		# Add the locale files to the list of files to generate.
83		my $files = $self->PL_files();
84		for my $lang ( $self->languages() ) {
85		# Add language specific files but skip the default: English.
86		if( $lang !~ /^en_?/ ) {
87		push @{ $files->{'build/mt-build.PL'} }, "lib/MT/L10N/$lang-iso-8859-1.pm"
88		unless $lang eq 'ja';
89		push @{ $files->{'build/mt-build.PL'} }, "mt-static/mt_$lang.js";
90		}
91		}
92		$self->PL_files( $files );
93		}
94
95		=head2 preprocess()
96
97		$build->preprocess();
98
99		This routine is called by the C<Build.PL> script and collects the
100		substitution configuration variables and adds the locale files to the
101		build object's C<PL_files> list.
102
103		=cut
104
105		sub substitute {
106		my $self = shift;
107		my $config = shift \|\| croak 'No configuration given to substitute';
108		my $file = shift \|\| croak 'No file given to substitute()';
109		warn "Substituting in $file...\n";
110
111		# Copy the pre-file and then substitute the config variables.
112		my $source = $file . '.pre';
113		copy( $source, $file ) \|\|
114		croak "Can't copy $source to $file: $!";
115
116		my $text = read_file( $file ); # File::Slurp
117
118		my $success = 0;
119		while( my( $key, $val ) = each %$config ) {
120		if( $text =~ /__$key\__/s ) {
121		$success++;
122		warn "Found $key. Replacing with $val\n";
123		$text =~ s/__$key\__/$val/gs;
124		}
125		}
126
127		write_file( $file, $text ) if $success; # File::Slurp
128
129		return $success;
130		}
131
132		=head2 substitute()
133
134		my $n = $build->substitute( \%config, $file )
135
136		Replace the strings (given by the hash reference keys) in the given
137		file with the corresponding values of the hash-ref and return the
138		number of successful matches.
139
140		=cut
141
142		sub make_js {
143		my $self = shift;
144		my $lang = shift \|\| croak 'No locale language given for make_js()';
145		my $file = shift \|\| croak 'No locale file given for make_js()';
146
147		my $class = 'MT::Util';
148		eval "require $class" or croak "ERROR: Can't require $class: $!";
149
150		# Import the language L10N lexicon.
151		eval 'require MT::L10N::'. $lang or
152		croak "ERROR: Can't require MT::L10N::$lang";
153		my $lex = eval '\%{ %MT::L10N::'. $lang .'::Lexicon }';
154		warn "Imported %MT::L10N::$lang\::Lexicon\n";
155
156		# Read-in the MT javascript.
157		my $source = 'mt-static/mt.js';
158		my $js = read_file( $source ); # File::Slurp
159		warn "Read-in $source contents.\n";
160
161		# Open the given locale js file.
162		my $fh = IO::File->new( '> '. $file );
163
164		print $fh "/* Movable Type language lexicon for $lang localization. */\n\n";
165
166		# Encode any matching lines.
167		while( $js =~ m/trans\('([^']+?)'/g ) {
168		my $str = $1;
169		my $local = $lex->{$str} \|\| $str;
170		$str = MT::Util::encode_js( $str );
171		$local = MT::Util::encode_js( $local );
172		next if $str eq $local;
173		print $fh "Lexicon['$str'] = '$local';\n";
174		}
175
176		# Bail out!
177		$fh->close;
178		warn "make_js: $file updated.\n";
179		}
180
181		=head2 make_js()
182
183		$build->make_js( $language, $file );
184
185		Create a JavaScript file for the given lnaguage.
186
187		=cut
188
189		sub make_latin1 {
190		my $self = shift;
191		my $lang = shift \|\|
192		croak "No locale language given for make_latin1()";
193		my $file = shift \|\|
194		croak "No file to convert given for make_latin1()";
195
196		# XXX en_us is used all over the code, instead of en_US.
197		$lang = lc $lang;
198
199		my $source = "lib/MT/L10N/$lang.pm";
200
201		# Read-in the file.
202		my $text = read_file( $source ); # File::Slurp
203		warn "Read $source contents.\n";
204
205		# Convert the file text.
206		my $conv = Text::Iconv->new( 'utf-8', 'iso-8859-1' );
207		$text = $conv->convert( $text );
208		warn "Converted $source contents.\n";
209
210		# Write out the converted file.
211		write_file( $file, $text ); # File::Slurp
212		warn "Wrote the converted contents to $file.\n";
213		}
214
215		=head2 make_latin1()
216
217		$build->make_latin1( $language, $file );
218
219		Convert file contents from utf-8 to iso-8859-1 and rename according to
220		the given language.
221
222		=cut
223
224		sub make_tarball {
225		my $self = shift;
226		$self->SUPER::make_tarball( @_ );
227		my $dist_dir = $self->dist_dir();
228		my $tar = Archive::Tar->new( "$dist_dir.tar.gz" ) or
229		croak "Can't read $dist_dir: $!";
230		$tar->extract() or
231		croak "Can't extract $dist_dir: $!";
232		my $zip = Archive::Zip->new();
233		$zip->addDirectory( $dist_dir ) or
234		croak "Can't read $dist_dir: $!";
235		$zip->writeToFileNamed( "$dist_dir.zip" ) or
236		croak "Can't create $dist_dir.zip: $!";
237		$self->delete_filetree( $dist_dir );
	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	# XXX Can't figure out how to pre-define arrays yet.
	123	# Make sure we have an archive file type list.
	124	$self->{'arch=s@'} \|\|= [qw( .tar.gz .zip )];
	125	# Make the plugins an empty list unless defined.
	126	$self->{'plugin=s@'} \|\|= [];
	127	}
	128
	129	sub setup {
	130	my $self = shift;
	131
	132	# Do we have SSL support?
	133	my $ssl = 'Crypt::SSLeay';
	134	eval { require $ssl };
	135	warn( "WARNING: $ssl not found. Can't use SSL.\n" ) if $@;
	136
	137	$self->{'pack=s'} \|\|= -e 'build/mt-dists/MTE.mk' ? 'MTE' : 'MT';
	138	$ENV{BUILD_PACKAGE} = $self->{'pack=s'};
	139	$ENV{BUILD_LANGUAGE} = $self->{'lang=s'};
	140
	141	# Handle option aliases.
	142	if( $self->{'prod'} or $self->{'alpha=s'} or $self->{'beta=s'} ) {
	143	$self->{'symlink!'} = 0;
	144	}
	145	if( $self->{'make'} ) {
	146	$self->{'build!'} = 0;
	147	$self->{'export!'} = 0;
	148	}
	149	if( $self->{'local'} ) {
	150	$self->{'export!'} = 0;
	151	}
	152	if( $self->{'stage'} ) {
	153	$self->{'deploy:s'} = $self->{'stage-dir=s'};
	154	}
	155
	156	# Grab our repository revision.
	157	$self->{'revision=s'} = repo_rev();
	158	# Figure out what repository to use.
	159	$self->set_repo();
	160
	161	# Make ab_CD into just ab.
	162	($self->{'short-lang=s'} = $self->{'lang=s'}) =~ s/([a-z]{2})_[A-Z]{2}$/$1/o;
	163
	164	# Create the build-stamp if one is not already defined.
	165	unless( $self->{'stamp=s'} ) {
	166	# Read-in the configuration variables for substitution.
	167	my $config = $self->read_conf( "build/mt-dists/$self->{'pack=s'}.mk" );
	168	my @stamp = ();
	169	push @stamp, $config->{PRODUCT_VERSION} . (
	170	$self->{'alpha=s'} ? "a$self->{'alpha=s'}"
	171	: $self->{'beta=s'} ? "b$self->{'beta=s'}"
	172	: '' );
	173	push @stamp, $self->{'short-lang=s'};
	174	# Add repo, date and ldap to the stamp if we are not production.
	175	unless( $self->{'prod'} ) {
	176	if( $self->{'rev!'} ) {
	177	push @stamp, lc( fileparse $self->{'repo=s'} );
	178	push @stamp, $self->{'revision=s'};
	179	}
	180	push @stamp, sprintf(
	181	'%04d%02d%02d', (localtime)[5]+1900, (localtime)[4]+1, (localtime)[3]
	182	) if $self->{'date!'};
	183	push @stamp, 'ldap' if $self->{'ldap'};
	184	}
	185	$self->{'stamp=s'} = join '-', @stamp;
	186	die( "ERROR: No stamp created. Cannot proceed.\n" )
	187	unless $self->{'stamp=s'};
	188	}
	189
	190	# Set the BUILD_VERSION_ID, which has not been defined until now.
	191	$ENV{BUILD_VERSION_ID} = $self->{'stamp=s'};
	192
	193	# Set the full name to use for the distribution (e.g. MT-3.3b1-fr-r12345-20061225).
	194	$self->{'export-dir=s'} = "$self->{'pack=s'}-$self->{'stamp=s'}";
	195	}
	196
	197	sub make {
	198	my $self = shift;
	199	$self->verbose( 'Entered make()' );
	200	return if $self->{'debug'};
	201
	202	if( !$self->{'debug'} && $self->{'export!'} ) {
	203	chdir( $self->{'export-dir=s'} ) or
	204	die( "ERROR: Can't cd to $self->{'export-dir=s'}: $!" );
	205	$self->verbose( "Change to the $self->{'export-dir=s'} directory" );
	206	}
	207
	208	if( $self->{'build!'} ) {
	209	$self->verbose_command( sprintf(
	210	'%s build/mt-dists/make-dists --package=%s --language=%s --stamp=%s %s',
	211	$^X,
	212	$self->{'pack=s'},
	213	$self->{'lang=s'},
	214	$self->{'export-dir=s'},
	215	($self->{'verbose!'} ? '--silent' : '')
	216	));
	217	}
	218	else {
	219	$self->verbose_command( 'make' );
	220	}
	221
	222	if( !$self->{'debug'} && $self->{'export!'} ) {
	223	chdir( '..' ) or die( "ERROR: Can't cd ..: $!" );
	224	$self->verbose( 'Change back to the parent directory' );
	225	}
	226	}
	227
	228	sub cleanup {
	229	my $self = shift;
	230	$self->verbose( 'Entered cleanup()' );
	231	return unless $self->{'cleanup!'};
	232
	233	my $build = $self->{'export-dir=s'}; # Less ugly.
	234	if( !$self->{'debug'} && $self->{'export!'} ) {
	235	# Move the build archives out of the soon-to-be-removed build directory.
	236	for my $arch ( @{ $self->{'arch=s@'} } ) {
	237	move( "$build/$build$arch", "$build$arch" )
	238	or die( "ERROR: Can't move $build/$build$arch: $!" );
	239	}
	240
	241	rmtree( $build ) or die( "ERROR: Can't rmtree clean-up $build: $!" );
	242	}
	243	$self->verbose( "Cleanup: Remove $build" );
	244	}
	245
	246	sub create_distro_list {
	247	my $self = shift;
	248
	249	my $distros = { path => [], url => [] };
	250
	251	my %seen = ();
	252
	253	for my $lang ( split( /\s,\s/, $self->{'lang=s'} ) ) {
	254	for my $arch ( @{ $self->{'arch=s@'} } ) {
	255	# The filename is the distribution name plus the archive extension.
	256	my $filename = $self->{'export-dir=s'} . $arch;
	257
	258	# The distribution is the full export path and filename.
	259	my $dist = File::Spec->catdir( $self->{'export-dir=s'}, $filename );
	260
	261	# Create lists of the distribution paths.
	262	push @{ $distros->{path} }, $dist;
	263
	264	# Add to the URL list depending on where we are deploying.
	265	if( $self->{'stage'} ) {
	266	# Magically use the internal production folder if it exists.
	267	my $loc = $self->{'prod'} && $self->{'prod-dir=s'} && $dist =~ /$self->{'prod-dir=s'}/
	268	? sprintf( "%s/%s/%s/mt.cgi",
	269	$self->{'stage-uri=s'}, $self->{'prod-dir=s'}, $self->{'export-dir=s'} )
	270	: sprintf( "%s/%s/mt.cgi", $self->{'stage-uri=s'}, $self->{'export-dir=s'} );
	271	push @{ $distros->{url} }, $loc unless $seen{$loc}++;
	272	}
	273	elsif( $self->{'deploy:s'} =~ /:/ ) {
	274	my $loc = sprintf '%s/%s', $self->{'deploy-uri=s'}, $filename;
	275	push @{ $distros->{url} }, $loc unless $seen{$loc}++;
	276	}
	277	}
	278	}
	279
	280	return $distros;
	281	}
	282
	283	sub deploy_distros {
	284	my $self = shift;
	285	my $distros = shift;
	286
	287	return unless $self->{'deploy:s'};
	288
	289	# If a colon is in the deployment string, use scp.
	290	if( $self->{'deploy:s'} =~ /:/ ) {
	291	$self->verbose_command( sprintf( '%s %s %s',
	292	'scp',
	293	join(' ', @{ $distros->{path} }),
	294	$self->{'deploy:s'}
	295	) );
	296	}
	297	# Otherwise, copy the distribution file(s) to the destination.
	298	else {
	299	for my $dist ( @{ $distros->{path} } ) {
	300	my $dest = '';
	301
	302	# Magically use the internal production folder if it exists.
	303	if( $self->{'prod'} && $self->{'stage'} && $self->{'prod-dir=s'} &&
	304	-e File::Spec->catdir( $self->{'stage-dir=s'}, $self->{'prod-dir=s'} )
	305	) {
	306	$dest = File::Spec->catdir(
	307	$self->{'deploy:s'},
	308	$self->{'prod-dir=s'},
	309	scalar fileparse( $dist ),
	310	);
	311	}
	312	else {
	313	$dest = File::Spec->catdir(
	314	$self->{'deploy:s'},
	315	scalar fileparse( $dist ),
	316	);
	317	}
	318
	319	copy( $dist, $dest ) or die( "ERROR: Can't copy $dist to $dest: $!" )
	320	unless $self->{'debug'};
	321	$self->verbose( "Copy $dist to $dest" );
	322
	323	# Install the build if we are staging.
	324	$self->stage_distro( $dest ) if $self->{'stage'};
	325
	326	# Update the build summary page.
	327	$self->update_html( $dest );
	328
	329	}
	330	}
	331
	332	# Make sure the deployed distros actually made it.
	333	unless( $self->{'debug'} ) {
	334	for( @{ $distros->{url} } ) {
	335	die( "ERROR: $_ can't be resolved." )
	336	unless $self->{'agent=s'}->head( $_ );
	337	}
	338	}
	339	}
	340
	341	sub stage_distro {
	342	my $self = shift;
	343	my $dest = shift;
	344
	345	# We only stage tar.gz's.
	346	return if $dest !~ /\.gz$/o;
	347
	348	die( "ERROR: Cannot stage '$dest': No such file or directory" )
	349	unless $self->{'debug'} \|\| -e $dest;
	350
	351	my $cwd = cwd();
	352
	353	chdir $self->{'stage-dir=s'} or
	354	die( "ERROR: Can't chdir to $self->{'stage-dir=s'}: $!" );
	355	$self->verbose( "Change to staging root $self->{'stage-dir=s'}" );
	356
	357	# Do we have a current symlink?
	358	my $link = lc( fileparse $self->{'repo=s'} );
	359	$link .= "-$self->{'short-lang=s'}";
	360	$link .= '-ldap' if $self->{'ldap'};
	361	my $current = '';
	362	$current = readlink( $link ) if $self->{'symlink!'} and -e $link;
	363	# Remove any trailing slash.
	364	$current =~ s/\/$//;
	365	# Database named the same as the distribution (but with _'s).
	366	(my $current_db = $current) =~ s/[.-]/_/g;
	367	$current_db = 'stage_' . $current_db;
	368
	369	# Grab the literal build directory name.
	370	my $stage_dir = fileparse( $dest, @{ $self->{'arch=s@'} } );
	371
	372	# Remove any existing distro, with the same path name.
	373	if( -d $stage_dir ) {
	374	rmtree( $stage_dir ) or
	375	die( "ERROR: Can't rmtree the old $stage_dir $!" )
	376	unless $self->{'debug'};
	377	$self->verbose( "Remove: $stage_dir" );
	378	}
	379
	380	# Drop previous.
	381	if( -d $current ) {
	382	rmtree( $current ) or
	383	warn( "WARNING: Can't rmtree previous '$current': $!" )
	384	unless $self->{'debug'};
	385	for my $arch ( @{ $self->{'arch=s@'} } ) {
	386	unlink( "$current$arch" ) or
	387	warn( "WARNING: Can't unlink '$current$arch': $!\n" )
	388	unless $self->{'debug'} or ("$current$arch" eq $dest);
	389	}
	390	}
	391
	392	# Tar-up the distribution.
	393	my $tar;
	394	unless( $self->{'debug'} ) {
	395	$self->verbose( "Extract: $dest..." );
	396	$tar = Archive::Tar->new( $dest );
	397	$tar->extract();
	398	}
	399	$self->verbose( "Extract: $dest" );
	400
	401	# Change to the distribution directory.
	402	chdir( $stage_dir ) or die( "ERROR: Can't chdir $stage_dir: $!" )
	403	unless $self->{'debug'};
	404	$self->verbose( "Change to $stage_dir" );
	405
	406	# Our database is named the same as the distribution (but with _'s) except for LDAP.
	407	(my $db = $stage_dir) =~ s/[.-]/_/g;
	408	# Reset the db to have the same name, if we are LDAP.
	409	$db = 'ldap' if $self->{'ldap'};
	410	# Append the handy staging build flag.
	411	$db = 'stage_' . $db;
	412
	413	# Set the staging URL to a real location now.
	414	my $url = sprintf '%s/%s/',
	415	$self->{'stage-uri=s'}, ($self->{'symlink!'} ? $link : $stage_dir);
	416
	417	# Give unto us a shiny, new config file.
	418	my $config = 'mt-config.cgi';
	419	unless( $self->{'debug'} ) {
	420	my $fh = IO::File->new( ">$config" );
	421	print $fh <<CONFIG;
	422	CGIPath $url
	423	DefaultSiteURL http://mt.sixapart.com/blogs/
	424	DefaultSiteRoot /var/www/html/mt-stage/blogs/
	425	Database $db
	426	ObjectDriver DBI::mysql
	427	DBUser root
	428	DebugMode 1
	429	CONFIG
	430	if( $self->{'ldap'} ) {
	431	print $fh <<CONFIG;
	432	AuthenticationModule LDAP
	433	AuthLDAPURL ldap://ldap.sixapart.com/dc=sixapart,dc=com
	434	CONFIG
	435	}
	436
	437	$fh->close();
	438	}
	439	$self->verbose( "Write configuration to $config" );
	440
	441	# Create and initialize a new database.
	442	unless( $self->{'ldap'} ) {
	443	# Set up the database for this distribution.
	444	$self->verbose( 'Initialize database.' );
	445	# XXX Use DBI ASAP.
	446	# Drop the previous database.
	447	$self->verbose_command( "mysqladmin -f -u root drop $current_db" )
	448	if $current;
	449	# Drop a database of same name.
	450	if( $db ) {
	451	$self->verbose_command( "mysqladmin -f -u root drop $db" );
	452	$self->verbose_command( "mysqladmin -u root create $db" );
	453	# Run the upgrade tool.
	454	$self->verbose_command( "$^X ./tools/upgrade --name Melody" );
	455	}
	456	else {
	457	die "ERROR: No database to stage - very odd.";
	458	}
	459	}
	460
	461	# Change to the parent of the new stage directory.
	462	chdir( '..' ) or die( "ERROR: Can't chdir to .." )
	463	unless $self->{'debug'};
	464	$self->verbose( 'Change back to staging root' );
	465
	466	# Now we re-link the stamped directory.
	467	if( $self->{'symlink!'} ) {
	468	unless( $self->{'debug'} ) {
	469	print "Unlink $link\n";
	470	# Drop current symlink.
	471	unlink( $link ) or warn( "WARNING: Can't unlink '$link': $!" );
	472	# Relink the staged directory.
	473	symlink( "$stage_dir/", $link ) or
	474	warn( "WARNING: Can't symlink $stage_dir/ to $link: $!" );
	475	}
	476	$self->verbose( "Symlink: $stage_dir/ to $link" );
	477	}
	478
	479	unless( $self->{'debug'} or $self->{'symlink!'} ) {
	480	# Make sure we can get to our symlink.
	481	$url = sprintf "%s/%s/mt.cgi",
	482	$self->{'stage-uri=s'}, $link;
	483	die( "ERROR: Staging $url can't be resolved." )
	484	unless $self->{'agent=s'}->head( $url );
	485	# Make sure we can get to our archive file symlinks.
	486	for my $arch ( @{ $self->{'arch=s@'} } ) {
	487	$url = sprintf '%s/%s%s',
	488	$self->{'stage-uri=s'}, $stage_dir, $arch;
	489	die( "ERROR: Staging $url can't be resolved." )
	490	unless $self->{'agent=s'}->head( $url );
	491	}
	492	}
	493
	494	chdir( $cwd ) or die( "ERROR: Can't chdir back to $cwd: $!" );
	495	}
	496
	497	sub update_html {
	498	my $self = shift;
	499	$self->verbose( 'Entered update_html()' );
	500	my $dest = shift;
	501
	502	if( $self->{'symlink!'} &&
	503	!$self->{'prod'} &&
	504	!$self->{'ldap'} &&
	505	($self->{'stage'} \|\| ($self->{'deploy:s'} eq $self->{'stage-dir=s'}))
	506	) {
	507	my( $stage_dir, $suffix );
	508	($stage_dir, undef, $suffix) = fileparse( $dest, @{ $self->{'arch=s@'} } );
	509	my $old_html = File::Spec->catdir( $self->{'stage-dir=s'}, 'build.html' );
	510
	511	unless( -e $old_html ) {
	512	warn "WARNING: Staging HTML file, $old_html, does not exist.\n";
	513	return;
	514	}
	515	unless( -e $stage_dir ) {
	516	warn "WARNING: Distribution file, $dest, does not exist.\n";
	517	return;
	518	}
	519
	520	my $id = lc( fileparse $self->{'repo=s'} ) . "-$self->{'short-lang=s'}$suffix";
	521	$self->verbose( "Update: $old_html with $id for $dest" );
	522
	523	unless( $self->{'debug'} ) {
	524	warn "WARNING: $old_html does not exist" unless -e $old_html;
	525	my $new_html = "$old_html.new";
	526	my $old_fh = IO::File->new( '< ' . $old_html );
	527	my $new_fh = IO::File->new( '> ' . $new_html );
	528
	529	while( my $line = <$old_fh> ) {
	530	if( $line =~ /id="($id)"/ ) {
	531	$self->verbose( "Matched: id=$id" );
	532	$line = sprintf qq\|<a id="%s" href="%s/%s%s">%s%s<\/a>\n\|,
	533	$id,
	534	$self->{'stage-uri=s'},
	535	$stage_dir, $suffix,
	536	$stage_dir, $suffix;
	537	}
	538	print $new_fh $line;
	539	}
	540
	541	$old_fh->close;
	542	$new_fh->close;
	543	move( $new_html, $old_html ) or
	544	die( "ERROR: Can't move $new_html, $old_html: $!" );
	545	$self->verbose( "Move: $new_html to $old_html" );
	546	}
	547	}
	548	}
	549
	550	sub remove_copy {
	551	my $self = shift;
	552	if( -d $self->{'export-dir=s'} ) {
	553	$self->verbose( "Remove existing export: $self->{'export-dir=s'}" );
	554	rmtree( $self->{'export-dir=s'} ) or
	555	die( "ERROR: Can't rmtree existing export $self->{'export-dir=s'}: $!" )
	556	unless $self->{'debug'};
	557	}
	558	}
	559
	560	sub repo_rev {
	561	my $revision = qx{ svn info \| grep 'Revision' };
	562	chomp $revision;
	563	$revision =~ s/^Revision: (\d+)$/r$1/o;
	564	die( "ERROR: $revision" ) if $revision =~ /is not a working copy/;
	565	return $revision;
	566	}
	567
	568	sub set_repo {
	569	my $self = shift;
	570
	571	# Grab our repository from the environment.
	572	$self->{'repo-uri=s'} = qx{ svn info \| grep URL };
	573	chomp $self->{'repo-uri=s'};
	574	$self->{'repo-uri=s'} =~ s/^URL: (.+)$/$1/o;
	575
	576	if( $self->{'repo-uri=s'} =~ /http.+?(branches\|tags)\/([0-9A-Za-z_.-]+)/ ) {
	577	# The repo is embedded in the repo uri.
	578	my( $key, $val ) = ( $1, $2 );
	579	$self->{'repo=s'} = join '/', $key, $val;
	580	}
	581
	582	# Make sure that the repository actually exists.
	583	if( !$self->{'debug'} && $self->{'export!'} ) {
	584	$self->{'agent=s'} = LWP::UserAgent->new;
	585	my $request = HTTP::Request->new( HEAD => $self->{'repo-uri=s'} );
	586	$request->authorization_basic( $self->{'http-user=s'}, $self->{'http-pass=s'} )
	587	if $self->{'http-user=s'} && $self->{'http-pass=s'};
	588	my $response = $self->{'agent=s'}->request( $request );
	589	die( "ERROR: The repoository '$self->{'repo-uri=s'}' can't be resolved." )
	590	unless $response->is_success;
	591	}
	592	}
	593
	594	sub export {
	595	my $self = shift;
	596	return unless $self->{'export!'};
	597	# NOTE Subversion auto-creates the export directory.
	598	$self->verbose_command( sprintf( '%s export --quiet %s %s',
	599	'svn', $self->{'repo-uri=s'}, $self->{'export-dir=s'}
	600	));
	601	}
	602
	603	sub plugin_export {
	604	my $self = shift;
	605	return unless $self->{'plugin=s@'};
	606
	607	# Change to the export directory, if we are exporting.
	608	chdir( $self->{'export-dir=s'} ) or
	609	die( "ERROR: Can't cd to $self->{'export-dir=s'}: $!" )
	610	if !$self->{debug} && $self->{'export!'};
	611
	612	# Export the plugins.
	613	for my $plugin ( @{ $self->{'plugin=s@'} } ) {
	614	my $uri = "$self->{'plugin-uri=s'}/$plugin";
	615	my $path = "plugins/$plugin";
	616	$self->verbose_command(
	617	sprintf( '%s export %s %s', 'svn', $uri, $path )
	618	);
	619	die "ERROR: Plugin not exported: $uri"
	620	unless $self->{debug} \|\| -d $path;
	621
	622	# Handle the plugin subdirectory.
	623	my $subdir = "$path/plugins/$plugin";
	624	if( -d $subdir && !$self->{debug} ) {
	625	$self->dirmove( $subdir, $path ) or
	626	die( "Can't move $subdir up to $path: $!" );
	627	$self->verbose( "Moved $subdir up to $path" );
	628	$subdir = "$path/plugins";
	629	rmtree( $subdir ) or
	630	die( "Can't rmtree() the $subdir $!" );
	631	$self->verbose( "Removed $subdir" );
	632	}
	633
	634	# Handle the mt-static subdirectory.
	635	my $static = "mt-static/plugins/$plugin";
	636	$subdir = "$path/$static";
	637	if( -d $subdir && !$self->{debug} ) {
	638	unless( -d $static ) {
	639	mkdir( $static ) or die( "Can't mkdir $static: $!" );
	640	$self->verbose( "Created $static" );
	641	}
	642	$self->dirmove( $subdir, $static ) or
	643	die( "Can't move directory $subdir to $static: $!" );
	644	$self->verbose( "Moved $subdir to $static" );
	645	$subdir = "$path/mt-static";
	646	rmtree( $subdir ) or
	647	die( "Can't rmtree() the $subdir: $!" );
	648	$self->verbose( "Removed $subdir" );
	649	}
	650	}
	651
	652	chdir( '..' ) or die( "ERROR: Can't cd ..: $!" )
	653	if !$self->{debug} && $self->{'export!'};
	654	}
	655
	656	sub dirmove {
	657	my $self = shift;
	658	my @paths = @_;
	659	my $dest = pop @paths;
	660	for my $path ( @paths ) {
	661	# $self->verbose( "Moving $path to $dest..." );
	662	eval{ install({ $path => $dest }) };
	663	}
	664	return 1;
	665	}
	666
	667	sub verbose_command {
	668	my $self = shift;
	669	my $command = shift;
	670	$self->verbose( "Execute: $command" );
	671	system $command unless $self->{'debug'};
	672
	673	if( $? == -1 ) {
	674	die( "ERROR: Failed to execute: $!" );
	675	}
	676	elsif( $? & 127 ) {
	677	die sprintf( "ERROR: Child died with signal %d, with%s coredump\n",
	678	( $? & 127 ), ( $? & 128 ? '' : 'out' )
	679	);
	680	}
	681	else {
	682	# printf "Child exited with value %d\n", $? >> 8 if $self->{'verbose!'};
	683	}
	684
	685	return $command;
	686	}
	687
	688	sub notify {
	689	my $self = shift;
	690	my $distros = shift;
	691
	692	return unless $self->{'notify:s'};
	693	$self->verbose( 'Entered notify()' );
	694	return if $self->{'debug'};
	695
	696	$self->{'email-subject=s'} = sprintf '%s build: %s',
	697	$self->{'pack=s'}, $self->{'stamp=s'};
	698	$self->{'email-subject=s'} .=
	699	$self->{'alpha=i'} ? ' - Alpha ' . $self->{'alpha=i'} :
	700	$self->{'beta=i'} ? ' - Beta ' . $self->{'beta=i'} :
	701	$self->{'prod'} ? ' - Production' :
	702	$self->{'stage'} ? ' - Staging' :
	703	$self->{'qa'} ? ' - QA' : '';
	704	# If an email-cc exists, add a comma in front of the QA address.
	705	$self->{'email-cc:s'} .= ($self->{'email-cc:s'} ? ',' : '') . 'sixapart@qasource.com'
	706	if $self->{'qa'};
	707	# Show the deployed URL's.
	708	$self->{'email-body=s'} = sprintf "File URL(s):\n%s\n\n",
	709	join( "\n", @{ $distros->{url} } )
	710	if $self->{'deploy:s'};
	711	$self->{'email-body=s'} .= sprintf "Build file(s) located on %s\n%s",
	712	hostname(), join( "\n", @{ $distros->{path} } )
	713	if $self->{'qa'} or !$self->{'cleanup!'};
	714
	715	my $smtp = Net::SMTP->new(
	716	$self->{'email-host=s'},
	717	Debug => $self->{'debug'},
	718	);
	719
	720	$smtp->mail( $self->{'email-from=s'} );
	721	$smtp->to( $self->{'notify:s'} );
	722	$smtp->cc( $self->{'email-cc:s'} ) if $self->{'email-cc:s'};
	723	$smtp->bcc( $self->{'email-bcc:s'} ) if $self->{'email-bcc:s'};
	724
	725	$smtp->data();
	726	$smtp->datasend( "To: $self->{'notify:s'}\n" );
	727	$smtp->datasend( "Cc: $self->{'email-cc:s'}\n" ) if $self->{'email-cc:s'};
	728	$smtp->datasend( "Subject: $self->{'email-subject=s'}\n" );
	729	$smtp->datasend( "\n" );
	730	$smtp->datasend( "$self->{'email-body=s'}\n" );
	731	$smtp->dataend();
	732
	733	$smtp->quit;
	734
	735	$self->verbose( "Email sent to $self->{'notify:s'}" );
238	736	}
239	737
240	738	sub read_conf {
	739	my $self = shift;
241	740	my @files = @_;
242	741	my $config = {};
243	742
244		~~# warn "Files: @files\n";~~
245	743	for my $file ( @files ) {
246	744	next unless -e $file;
247		~~warn "Parsing~~ config $file file...\n";
	745	print "Parse: config $file file...\n";
248	746	my $fh = IO::File->new( '< ' . $file );
249	747
…	…
265	763	}
266	764
267		=head2 read_conf()
268
269		$config = $build->read_config( @files );
270
271		Read-in the given configuration files with B<key = value> pairs per
272		line and return a single hash reference of B<key => "value"> pairs.
273
274		=cut
	765	sub inject_footer {
	766	my $self = shift;
	767	$self->verbose( 'Entered inject_footer()' );
	768	return if $self->{'prod'} \|\| $self->{'debug'};
	769
	770	my $file = $self->{'export!'}
	771	? File::Spec->catdir( $self->{'export-dir=s'}, $self->{'footer-tmpl=s'} )
	772	: $self->{'footer-tmpl=s'};
	773	die( "ERROR: File $file does not exist: $!" ) unless -e $file;
	774
	775	# Slurp-in the contents of the file.
	776	local $/;
	777	my $fh = IO::File->new( $file );
	778	my $contents = <$fh>;
	779	$fh->close();
	780
	781	$contents =~ s/Reserved.\n/Reserved.\n$self->{'footer=s'}/;
	782
	783	# Rewrite the file with the injected footer.
	784	$fh = IO::File->new( "> $file" );
	785	print $fh $contents;
	786	$fh->close();
	787	}
	788
	789	sub verbose {
	790	my $self = shift;
	791	return unless $self->{'verbose!'};
	792	print join( "\n", @_ ), "\n\n";
	793	}
	794
	795	sub debug { shift->{'debug'} }
	796	sub help { shift->{'help\|h'} }
	797	sub usage {
	798	my $self = shift;
	799	print <<'USAGE';
	800
	801	MT export build deployment notification automation.
	802	Examples:
	803
	804	cd $MT_DIR
	805	svn update
	806	perl build/exportmt.pl --help
	807	perl build/exportmt.pl --debug
	808	# --alpha=1
	809	# --beta=42
	810	# --local
	811	# --make
	812	# --plugin=Foo --plugin=Foo
	813	# --prod
	814	# --qa
	815	# --stage
	816
	817	Please see the full documentation at:
	818	https://intranet.sixapart.com/wiki/index.php/Movable_Type:MT_Export-Deploy
	819
	820	USAGE
	821	exit;
	822	}
275	823
276	824	1;
	825	__END__

branches/wheeljack/build/exportmt.pl

r666	r702
1	1	#!/usr/bin/perl
2		#
3	2	# $Id$
4		#
5	3	use strict;
6	4	use warnings;
7		use Archive::Tar;
8		use Cwd;
9		use Getopt::Long;
10		use File::Basename;
11		use File::Copy;
12		use File::Path;
13		use File::Spec;
14		use IO::File;
15		use LWP::UserAgent;
16		use Net::SMTP;
17		use Sys::Hostname;
	5	use lib 'build';
	6	use Build;
18	7	use Data::Dumper;
19	8	$Data::Dumper::Indent = $Data::Dumper::Terse = $Data::Dumper::Sortkeys = 1;
20	9
21		# Flush the output buffer.
22		$\|++;
	10	my $build = Build->new();
23	11
24		# Show the usage if there are no command-line arguments provided.
25		usage() unless @ARGV;
	12	$build->usage() unless @ARGV;
26	13
27		# Set-up the command-line options with their default values.
28		my %o = get_options(
29		'agent=s' => '', # Constructed at run-time.
30		'alpha=s' => 0, # Alpha build number.
31		'arch=s' => [qw( .tar.gz .zip )],
32		'beta=s' => 0, # Beta build number.
33		'cleanup!' => 1, # Remove the exported directory after deployment.
34		'date!' => 1, # Toggle date stamping.
35		'debug' => 0, # Turn on/off the actual system calls.
36		'deploy:s' => '', #($ENV{USER}\|\|$ENV{USERNAME}).'@rongo:/usr/local/cifs/intranet/mt-interest/',
37		'deploy-uri=s' => 'https://intranet.sixapart.com/mt-interest',
38		'email-bcc:s' => undef,
39		'email-body=s' => '', # Constructed at run-time.
40		'email-cc:s' => undef,
41		'email-from=s' => ( $ENV{USER} \|\| $ENV{USERNAME} ) .'@sixapart.com',
42		'email-host=s' => 'mail.sixapart.com',
43		'email-subject=s' => '', # Constructed at run-time.
44		'export!' => 1, # To export or not to export. That is the question.
45		'export-dir=s' => '', # Constructed at run-time.
46		'footer=s' => "<br/><b>SOFTWARE IS PROVIDED FOR TESTING ONLY - NOT FOR PRODUCTION USE.</b>\n",
47		'footer-tmpl=s' => 'tmpl/cms/footer.tmpl',
48		'help\|h' => 0, # Show the program usage.
49		'http-user=s' => undef,
50		'http-pass=s' => undef,
51		'ldap' => 0, # Use LDAP (and don't initialize the database).
52		'lang=s' => $ENV{BUILD_LANGUAGE} \|\| 'en_US', # de,es,en_US,fr,ja,nl
53		'local' => 0, # Command-line --option alias
54		'notify:s' => undef, # Send email no