#!/usr/bin/perl -w
use strict;

=head1 NAME

bric_media_dump - Dump all of the media files of a given type

=head1 SYNOPSIS

Dump all of the "Illustration" media files into the current directory:

  bric_media_dump --media-type Illustration

Dump all of the "illustration" media files in the "Default Site" site to a
specific directory:

  bric_media_dump --site 'Default Site' --output-to /my/path \
    --media-type illustration

=head1 OPTIONS

bric_media_dump [options]

=head2 Options

=over 4

=item C<--username>

The Bricolage username to use to connect to the server. Defaults to the
C<BRICOLAGE_USERNAME> environment variable if set.

=item C<--password>

The password to use when connecting to the Bricolage server with the username
specified by C<--username>. Defaults to the C<BRICOLAGE_PASSWORD> environment
variable if set.

=item C<--media-type>

The key name of the media type element that defines the structure of the media
documents to be dumped.

=item C<--server>

The URL to the Bricolage server. Defaults to "http://localhost/".

=item C<--site>

Name of the site from which the media are to be dumped. This is useful if
there is more than one site with the same name.

=item C<--output-to>

Specifies a directory to act as the category root for the output of all the
media files. The directory will be created if it doesn't exist. Defaults
to the current directory.

=item C<--help>

Shows this screen.

=item C<--man>

Shows the full documentation.

=item C<--version>

Shows the version number.

=item C<--verbose>

Prints a running dialogue of operations. Repeat up to three times of
successively larger amounts of debugging information.

=item C<--timeout>

Specifies the HTTP timeout for SOAP requests in seconds. Defaults to 60.

=back

=head1 DESCRIPTION

This program dumps the files from all of the current, active media documents
of a given type. The media files will be written to the current directory
unless the C<--output-to> option is used. F<bric_media_dump> will recreate the
category structure of for the media documents as necessary to properly output
all of the media files.

=head1 AUTHOR

David Wheeler <david@kineticode.com>.

Based on code from F<bric_template_dump>.

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2004 Kineticode, Inc. All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

use Getopt::Long;
use Pod::Usage;
use File::Spec::Functions qw(curdir canonpath catdir splitdir catfile);

my ($username, $password, $server, $output_to, $VERBOSE, $timeout, $help,
    $man, $oc, $site, $show_ver, $type);

BEGIN {
    our $VERSION = '0.10';

    # Get parameters from command line. Do so at compile time so that $VERBOSE
    # can effect use options and such.
    $username        = $ENV{BRICOLAGE_USERNAME};
    $password        = $ENV{BRICOLAGE_PASSWORD};
    $server          = 'http://localhost/';
    $output_to       = curdir;
    $VERBOSE         = 0;
    $timeout         = 60;
    GetOptions("help"                   => \$help,
	       "man"                    => \$man,
	       "verbose+"               => \$VERBOSE,
	       "username=s"             => \$username,
	       "password=s"             => \$password,
	       "media-type=s"           => \$type,
	       "site=s"                 => \$site,
	       "server=s"               => \$server,
               "timeout=s"              => \$timeout,
               "output-to=s"            => \$output_to,
               "version+"               => \$show_ver,
	      ) or pod2usage(2);

    pod2usage(1)             if $help;
    pod2usage(-verbose => 2) if $man;
    print "$0 version $VERSION\n" and exit if $show_ver;

    # Check required options
    pod2usage("Missing required --username option ".
	      "and BRICOLAGE_USERNAME environment variable unset.")
	unless defined $username;
    pod2usage("Missing required --password option ".
	      "and BRICOLAGE_PASSWORD environment variable unset.")
	unless defined $password;

    pod2usage("Missing required --media-type option.")
	unless defined $type;
};

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

use SOAP::Lite ($VERBOSE > 2 ? (trace => [qw(debug)]) : ());
import SOAP::Data 'name';
use HTTP::Cookies;
use File::Path qw(mkpath);
use MIME::Base64 qw(decode_base64 encode_base64);
use XML::Simple qw(XMLin);
use File::Spec::Unix;

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

# Connect to the SOAP server.
my $soap = login($username, $password, $server, $timeout);
fetch_media($soap, $type, $site, $output_to);
print STDERR "$0 finished okay\n" if $VERBOSE;

##############################################################################
# This subroutine connects to the Bricolage server and returns the SOAP::Lite
# object.
##############################################################################
sub login {
    my ($username, $password, $server, $timeout) = @_;

    # Fixup url if missing "http://" or ending in "/".
    $server = "http://$server" unless $server =~ m!^https?://!;
    $server =~ s|/$||;

    # setup soap object to login with
    my $soap = SOAP::Lite->new(
	uri      => 'http://bricolage.sourceforge.net/Bric/SOAP/Auth',
        readable => $VERBOSE >= 2 ? 1 : 0
    );

    $soap->proxy($server . '/soap',
		 cookie_jar => HTTP::Cookies->new(ignore_discard => 1),
		 timeout    => $timeout);

    # Log in.
    print STDERR "Logging in to $server as $username...\n" if $VERBOSE;
    my $response = $soap->login(name(username => $username),
				name(password => $password));
    die "Login to $server as $username failed.\n" if $response->fault;
    print STDERR "Login to $server success.\n" if $VERBOSE;
    return $soap;
}

##############################################################################
# This subroutine fetches all of the media documents from the Bricolage
# server.
##############################################################################
sub fetch_media {
    my ($soap, $type, $site, $output_to) = @_;
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/Media');
    print STDERR "Dumping $type media\n" if $VERBOSE;
    my $response = $soap->list_ids(name(element_key_name => $type),
                                   $site ? name(site => $site) : ());

    _print_fault($response) if $response->fault;
    my @media_ids = @{ $response->result };
    print STDERR "Found media IDs: ", join(',', @media_ids), "\n"
      if $VERBOSE;

    foreach my $media_id (@media_ids) {
        # Export the media.
        $response = $soap->export(name( media_id => $media_id));
        _print_fault($response) if $response->fault;

        # Parse the XML and extract the media code and file name.
        my $xml = XMLin($response->result);
        my $contents = $xml->{media}{file}{data}
          ? decode_base64($xml->{media}{file}{data})
          : '';

        my $filename = $xml->{media}{uri};
        print STDERR "Extracted media '$filename' ($media_id): "
          . length($contents) . " bytes.\n"
          if $VERBOSE;

        # Construct the target location.
        my $path = catfile($output_to, File::Spec::Unix->splitdir($filename));

        # Make the target directory, if needed.
        my @parts = splitdir($path);
        my $loc = catdir(@parts[0..$#parts-1]);
        mkpath([$loc]) unless -d $loc;

        # Write out the media.
        print STDERR "Writing '$path'\n" if $VERBOSE;
        open(MEDIA, ">$path") or die "Unable to open $path : $!";
        print MEDIA $contents;
        close MEDIA or die $!;
    }
}

##############################################################################
# This subroutine prints out a relevant SOAP error message and dies.
##############################################################################
sub _print_fault {
    my $r = shift;
    if ($r->faultstring eq 'Application error' and
	ref $r->faultdetail and ref $r->faultdetail eq 'HASH') {
	# This is a Bricolage exception, the interesting stuff is in detail.
	die "Call to Bric::SOAP failed : \n" .
	    join("\n", values %{$r->faultdetail});
    } else {
        # Just die with the fault string.
	die "Call to Bric::SOAP failed : \n" . $r->faultstring;
    }
}
