Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Added bric_media_dump contrib script.
  • Loading branch information
theory committed Aug 11, 2004
1 parent a6ab103 commit 1299cef
Show file tree
Hide file tree
Showing 14 changed files with 424 additions and 6 deletions.
20 changes: 20 additions & 0 deletions contrib/bric_media_dump/Build.PL
@@ -0,0 +1,20 @@
use Module::Build;

my $build = Module::Build->new
( module_name => 'bric_media_dump',
license => 'perl',
create_makefile_pl => 'passthrough',
script_files => [ 'bin/bric_media_dump' ],
dist_version_from => 'bin/bric_media_dump',
pm_files => {},
requires => { Getopt::Long => 0,
Pod::Usage => 0,
SOAP::Lite => 0,
File::Spec => 0,
HTTP::Cookies => 0,
File::Path => 0,
MIME::Base64 => 0,
XML::Simple => 0,
},
);
$build->create_build_script;
4 changes: 4 additions & 0 deletions contrib/bric_media_dump/Changes
@@ -0,0 +1,4 @@
Revision history for bric_media_dump.

0.10 2004-08-11T19:18:10
- Initial release.
9 changes: 9 additions & 0 deletions contrib/bric_media_dump/MANIFEST
@@ -0,0 +1,9 @@
bin/bric_media_dump
Build.PL
Changes
Makefile.PL
MANIFEST This list of files
META.yml
README
t/bric_media_dump.t
t/zpod.t
9 changes: 9 additions & 0 deletions contrib/bric_media_dump/MANIFEST.SKIP
@@ -0,0 +1,9 @@
^_build
^Build$
^blib
~$
\.bak$
^MANIFEST\.SKIP$
^bric_media_dump
^www
\.svn
18 changes: 18 additions & 0 deletions contrib/bric_media_dump/META.yml
@@ -0,0 +1,18 @@
--- #YAML:1.0
name: bric_media_dump
version: 0.10
author:
- David Wheeler <david@kineticode.com>.
abstract: Dump all of the media files of a given type
license: perl
requires:
File::Path: 0
File::Spec: 0
Getopt::Long: 0
HTTP::Cookies: 0
MIME::Base64: 0
Pod::Usage: 0
SOAP::Lite: 0
XML::Simple: 0
provides: {}
generated_by: Module::Build version 0.25_01
31 changes: 31 additions & 0 deletions contrib/bric_media_dump/Makefile.PL
@@ -0,0 +1,31 @@
# Note: this file was auto-generated by Module::Build::Compat version 0.03

unless (eval "use Module::Build::Compat 0.02; 1" ) {
print "This module requires Module::Build to install itself.\n";

require ExtUtils::MakeMaker;
my $yn = ExtUtils::MakeMaker::prompt
(' Install Module::Build now from CPAN?', 'y');

unless ($yn =~ /^y/i) {
die " *** Cannot install without Module::Build. Exiting ...\n";
}

require Cwd;
require File::Spec;
require CPAN;

# Save this 'cause CPAN will chdir all over the place.
my $cwd = Cwd::cwd();
my $makefile = File::Spec->rel2abs($0);

CPAN::Shell->install('Module::Build::Compat')
or die " *** Cannot install without Module::Build. Exiting ...\n";

chdir $cwd or die "Cannot chdir() back to $cwd: $!";
exec $^X, $makefile, @ARGV; # Redo now that we have Module::Build
}
use lib '_build/lib';
Module::Build::Compat->run_build_pl(args => \@ARGV);
require Module::Build;
Module::Build::Compat->write_makefile(build_class => 'Module::Build');
36 changes: 36 additions & 0 deletions contrib/bric_media_dump/README
@@ -0,0 +1,36 @@
bric_media_dump 0.10
====================

This program may be used to dump all of the media files of a given type from
a Bricolage server.

INSTALLATION

To install this module, type the following:

perl Build.PL
./Build
./Build test
./Build install

DEPENDENCIES

This program requires these other modules and libraries:

Getopt::Long
Pod::Usage
SOAP::Lite
File::Spec
HTTP::Cookies
File::Path
MIME::Base64
XML::Simple

It also requires a Bricolage server.

COPYRIGHT AND LICENCE

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

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
261 changes: 261 additions & 0 deletions contrib/bric_media_dump/bin/bric_media_dump
@@ -0,0 +1,261 @@
#!/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;
}
}

0 comments on commit 1299cef

Please sign in to comment.