#!/usr/bin/perl --
#↑ この行は admin.cgi の1行目と同じになるように書き換えて下さい。

#######################################################################

=pod
すぐ使えるCMS バックアップツール Ver. 0.8

2017年11月8日　Ver. 0.8 公開

Copyright(c) 2017 Sugutsukaeru Inc. All rights reserved.
http://cms.sugutsukaeru.jp/

このプログラムは「すぐ使えるCMS」のバックアップ用ユーティリティです。

著作権は作者が保有しています。
ご自身でご利用になる場合改変は自由です。
再配布および改変品の再配布はご遠慮下さい。
=cut

#######################################################################



my ( %conf, %work );

######### 環境設定 ## ここから #################
# ※ 通常は変更の必要はありません。

#バックアップファイルの先頭に付けるファイル名。この後に日付と拡張子が付きます。
$conf{file_prefix} = 'CMS-backup';

#バックアップ対象の「すぐ使えるCMS」の管理画面ファイル。
$conf{admin_cgi} = './admin.cgi';

#バックアップ対象のディレクトリ（「すぐ使えるCMS」の変数名で指定）。
$conf{target_dirs} = [ qw(
	  data_dir
	  web_dir
	  ) ];

#zipコマンドの指定。
$conf{zip_command} = 'zip';

#C#C##### 環境設定 ## ここまで #################

$work{modules} = {
	filetemp => {
		name       => 'File::Temp',
		use_string => 'use File::Temp qw( tempfile )',
	},
	basename => {
		name       => 'File::Basename',
		use_string => 'use File::Basename qw( basename dirname )',
	},
	archivezip => {
		name       => 'Archive::Zip',
		use_string => 'use Archive::Zip qw( :ERROR_CODES :CONSTANTS )',
	},
};

{
	local $SIG{__DIE__} = \&print_error;

	for my $m ( keys %{ $work{modules} } ) {
		eval $work{modules}->{$m}->{use_string};
		my $mn = sprintf( '%s.pm', $work{modules}->{$m}->{name} );
		$mn =~ s@:{2}@/@g;
		if ( exists $INC{$mn} ) {
			$work{modules}->{$m}->{ok} = 1;
		} else {
			$work{modules}->{$m}->{ok} = 0;
		}
	} ## end for my $m ( keys %{ $work...})

	if ( my @nomodule = map { $_->{name} } grep { $_->{ok} == 0 } map { $work{modules}->{$_} } qw(basename filetemp) ) {
		die sprintf( '右の必要モジュールがありません。: %s' . "\n", join( ", ", @nomodule ) );
	}

	{
		my @get_conf_value = &get_conf_value( $conf{admin_cgi}, $conf{target_dirs} );
		if ( $get_conf_value[0] == 1 ) {
			$work{paths} = $get_conf_value[1];
		} else {
			die $get_conf_value[1] . "\n";
		}
	}

	unless ( grep { -d $_ } @{ $work{paths} } ) {
		die 'バックアップ対象ファイルはありません。' . "\n";
	}

	{
		my @lt = localtime();
		$work{backup_filename} = sprintf( '%s-%d%02d%02d-%02d%02d.zip',
			$conf{file_prefix},
			$lt[5] + 1900,
			$lt[4] + 1,
			$lt[3],
			$lt[2],
			$lt[1],
		);
	}

	if ( $work{modules}->{archivezip}->{ok} == 1 ) {
		use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
		my $zip;
		eval { $zip = Archive::Zip->new() };

		for my $dir ( @{ $work{paths} } ) {
			unless ( AZ_OK == eval { $zip->addTree( $dir, basename($dir) ) } ) {
				die '圧縮処理に失敗しました。: ' . $@;
			}
		}
		binmode STDOUT, ":raw";
		print "Content-Type: application/zip;\015\012";
		print "Content-Disposition: attachment; filename=$work{backup_filename}\015\012";
		print "\015\012";
		$zip->writeToFileHandle( *STDOUT, 0 );
	} else {
		my ( $fh, $f ) = tempfile( SUFFIX => '.zip' );
		close($fh);
		unlink($f);
		my $origin = dirname($0);
		for my $dir ( @{ $work{paths} } ) {
			my $parent_dir = dirname($dir);
			chdir $parent_dir or die "Can't change directory to $parent_dir.\n";
			my $current_dir = `pwd`;
			my $command     = sprintf( '%s -r -q %s %s',
				$conf{zip_command},
				$f,
				basename($dir),
			);
			eval { system $command}
			  and die "Command [$command] failed.: $@";
			chdir $origin or die "Can't change directory to the original dir $origin.\n";
		} ## end for my $dir ( @{ $work{...}})

		open $fh, '<', $f or die "Can't read zip file that was created as $f.\n";
		binmode $fh, ':raw';
		print "Content-Type: application/zip;\015\012";
		print "Content-Disposition: attachment; filename=$work{backup_filename}\015\012";
		print "\015\012";
		while ( read $fh, my $buf, 1024 * 16 ) {
			print $buf;
		}
		close $fh;
		unlink $f;
	} ## end else [ if ( $work{modules}->{...})]
}

sub print_error {
	my @str = @_;
	print "Content-Type: text/plain;charset=shift_jis\015\012";
	print "\015\012";
	print 'エラーが起きました。このサーバでは使えない可能性があります。' . "\n";
	print '▼エラー情報▼' . "\n";
	print join( "\n", @str );
	exit;
} ## end sub print_error

sub get_conf_value {
	my ( $file, $target_names_ref ) = @_;
	defined $file and length $file and -f $file or return ( 0, "CMS admin.cgi file is not properly set." );

	my $fh;
	unless ( open( $fh, "<:raw", $file ) ) {
		return ( 0, "Open failed: $file: $!" );
	}

	my %check_if_got;
	@check_if_got{ @{$target_names_ref} } = ();

	my @path;
	while (<$fh>) {
		index( $_, '$conf' ) == 0 or next;
		for my $ckey ( @{$target_names_ref} ) {
			exists $check_if_got{$ckey} or next;
			if ( $_ =~ m/^\$conf\{$ckey\}\s*=\s*['"]([^'"]*)['"]\s*;\s*/ ) {
				my $val = $1;
				unless ( !$val or $val eq '' ) {
					push( @path, $val );
				}
				delete $check_if_got{$ckey};
			} ## end if ( $_ =~ ...)
		} ## end for my $ckey ( @{$target_names_ref...})
		scalar %check_if_got or last;
	} ## end while (<$fh>)
	close($fh);
	return ( 1, \@path );
} ## end sub get_conf_value

1;