Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Browse files
Browse the repository at this point in the history
Added bric_media_dump contrib script.
- Loading branch information
Showing
14 changed files
with
424 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,4 @@ | ||
Revision history for bric_media_dump. | ||
|
||
0.10 2004-08-11T19:18:10 | ||
- Initial release. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,9 @@ | ||
^_build | ||
^Build$ | ||
^blib | ||
~$ | ||
\.bak$ | ||
^MANIFEST\.SKIP$ | ||
^bric_media_dump | ||
^www | ||
\.svn |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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'); |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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; | ||
} | ||
} |
Oops, something went wrong.