Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 375 lines (328 sloc) 8.08 KB
#!/usr/bin/perl -w
#This program is licensed under the BSD 2-Clause License a copy of which
#is included with this program.
# (c) Ian Malone 2012
use Image::ExifTool qw(ImageInfo);
use MIME::Base64;
use File::Basename qw(basename);
use strict;
my $prog = basename $0;
my %allowedmime = (
"image/png" => {
depth => sub {
my $EI = $_[0];
return if ! defined $EI->{BitDepth};
return $EI->{BitDepth};
}
},
"image/jpeg" => {
depth => sub {
my $EI = $_[0];
return if ! defined $EI->{BitsPerSample} ||
! defined $EI->{ColorComponents};
return $EI->{BitsPerSample} * $EI->{ColorComponents};
}
}
);
my $wblock64 = "block64";
my $wblockraw = "blockraw";
my $wtag = "tag";
my %typenames = (
Other => 0,
FileIconSmall => 1,
FileIcon => 2,
CoverFront => 3,
CoverBack => 4,
Leaflet => 5,
Media => 6,
ArtistLead => 7,
Artist => 8,
Conductor => 9,
Band => 10,
Composer => 11,
Lyricist => 12,
Location => 13,
Recording => 14,
Performance => 15,
ScreenCapture => 16,
ABrightColouredFish => 17,
Illustration => 18,
BandLogo => 19,
PublisherLogo => 20
);
my %opt = readOpts(@ARGV);
if ( ! -f $opt{inimg} ) {
print "Couldn't find $opt{inimg}\n";
exit 1;
}
my $flacblock = fillBlockInfo($opt{inimg}, $opt{type}, $opt{desc});
printblock($flacblock) if $opt{verbose};
testiconsmall($flacblock) if $opt{type} == 1;
writeblock($flacblock, $opt{outname}, $opt{writemode});
sub readOpts {
my %opt = (
writemode => $wtag,
inimg => "",
outname => "",
desc => "",
type => 0,
verbose => 0
);
my $usage = getUsage();
my $ARGPROBS=0;
my $HELP = 0;
while (my $arg = shift @_) {
if ($arg eq "-i") {
if (@_ < 1) {
print "$arg requires an argument\n";
$ARGPROBS=1;
}
else {
$opt{inimg} = shift @_;
}
}
elsif ($arg eq "-o") {
if (@_ < 1) {
print "$arg requires an argument\n";
$ARGPROBS=1;
}
else {
$opt{outname} = shift @_;
}
}
elsif ($arg eq "-desc") {
if (@_ < 1) {
print "$arg requires an argument\n";
$ARGPROBS=1;
}
else {
$opt{desc} = shift @_;
}
}
elsif ($arg eq "-type") {
if (@_ < 1) {
print "$arg requires an argument\n";
$ARGPROBS=1;
}
else {
$opt{type} = shift @_;
}
}
elsif ($arg eq "-write") {
if (@_ < 1) {
print "$arg requires an argument\n";
$ARGPROBS=1;
}
else {
my $reqmode = shift @_;
my $gotmode = "";
for my $test ($wblock64, $wblockraw, $wtag) {
$gotmode = $test if $test eq $reqmode;
}
if ( $gotmode ne "" ){
$opt{writemode} = $gotmode;
}
else {
print "'$reqmode' not recognised\n";
$ARGPROBS=1;
}
}
}
elsif ($arg eq "-v") {
$opt{verbose} = 1;
}
elsif ($arg eq "-h" || $arg eq "-help") {
$HELP = 1;
}
else {
print "$arg not recognised\n";
$ARGPROBS=1;
}
}
if ($HELP) {
print $usage;
exit 0;
}
if ($opt{inimg} eq "") {
print "Need an input image\n";
$ARGPROBS=1;
}
if (defined $opt{outname} eq "") {
print "Need an output name\n";
$ARGPROBS=1;
}
elsif ( -e $opt{outname} ) {
print "$opt{outname} already exists\n";
$ARGPROBS=1;
}
$opt{type} = $typenames{$opt{type}} if defined $typenames{$opt{type}};
if ( ($opt{type} !~ /^\d+$/ || $opt{type} > 20) ) {
# Regex doesn't allow <0
print "Type must be in range [0:20] or from list (see help)\n";
$ARGPROBS=1;
}
if ($ARGPROBS) {
print "For help:\n$prog -h\n";
exit 1;
}
return %opt;
}
sub getrawfile {
my $inimg = $_[0];
open FILE, "<", "$inimg" or die $!;
binmode FILE;
my $imgcontents;
my $size=0;
my $chunksize=200*1024;
while ( ! eof(FILE) ) {
my $read = read FILE, $imgcontents, $chunksize, $size;
$size += $read;
}
if ($size < 1) {
print "Couldn't read $inimg\n";
exit 1;
}
close FILE;
my $rawimg = {
imgcontents => $imgcontents,
imgsize => $size
};
return $rawimg;
}
sub printBlock {
my $blockinfo = $_[0];
for my $key (keys %$blockinfo) {
next if $key eq "imagecontents";
print "$key $blockinfo->{$key}\n";
}
}
sub fillBlockInfo {
my ($inimg, $type, $desc) = @_;
my $blockinfo = {
type => $type,
mime => "",
desc => $desc,
width =>0,
height =>0,
depth =>0,
palette =>0,
imagesize =>0
};
my $exifinfo = ImageInfo($inimg) or die $!;
if ( !defined $exifinfo || !defined $exifinfo->{MIMEType} ) {
print "Failed getting mime type for $inimg\n";
exit 1;
}
my $mimetype=$exifinfo->{MIMEType};
if ( ! defined $allowedmime{$mimetype} ) {
print "$inimg has MIME Type '$exifinfo->{MIMEType}'\n";
print (join(" ", "Allowed MIME types are",keys(%allowedmime))."\n");
exit 1;
}
$blockinfo->{mime} = $mimetype;
$blockinfo->{depth} = $allowedmime{$mimetype}->{depth}($exifinfo);
$blockinfo->{height} = $exifinfo->{ImageHeight};
$blockinfo->{width} = $exifinfo->{ImageWidth};
my $dataprob=0;
for my $check (qw(mime depth height width)) {
if (! defined $blockinfo->{$check} ) {
print "Error determining $check.\n";
}
}
if ($dataprob){
exit 1;
}
$blockinfo->{mimelength}=length ($blockinfo->{mime});
$blockinfo->{desclength}=length ($blockinfo->{desc});
my $rawfile = getrawfile ($inimg);
$blockinfo->{imagesize}=$rawfile->{imgsize};
$blockinfo->{imagecontents}=$rawfile->{imgcontents};
return $blockinfo;
}
sub packblock {
my ($blockinfo) = $_[0];
my $packformat = sprintf "(L[2]A[%d]LA[%d]L[5]a[%d])>",
$blockinfo->{mimelength},
$blockinfo->{desclength},
$blockinfo->{imagesize};
my $block = pack (
$packformat,
$blockinfo->{type}, #32bit
$blockinfo->{mimelength}, #32bit
$blockinfo->{mime},
$blockinfo->{desclength}, #32bit
$blockinfo->{desc},
$blockinfo->{width}, #32bit
$blockinfo->{height}, #32bit
$blockinfo->{depth}, #32bit
$blockinfo->{palette}, #32bit
$blockinfo->{imagesize}, #32bit
$blockinfo->{imagecontents}
);
return $block;
}
sub writeblock {
my ($blockinfo, $outname, $writemode) = @_;
my $block = packblock($blockinfo);
my $output = "";
if ( $writemode eq $wtag ) {
$output = "METADATA_BLOCK_PICTURE=";
}
if ( $writemode eq $wblock64 || $writemode eq $wtag ) {
$output .= encode_base64( $block, "" ) . "\n";
}
elsif ( $writemode eq $wblockraw ) {
$output = $block;
}
open (OUT, ">", $outname) || die $!;
binmode OUT or die $! if $writemode eq $wblockraw;
if ( ! print OUT $output
||
! close OUT
)
{
print "Error writing to $outname\n";
}
}
sub testiconsmall {
my ($blockinfo) = @_;
my $okay =
$blockinfo->{height} == 32 &&
$blockinfo->{width} == 32 &&
$blockinfo->{mime} eq "image/png"
;
if (!$okay) {
die "FileIconSmall must be 32x32 png\n";
}
}
sub getUsage {
my $typelist = "";
my @names = keys %typenames;
@names = sort ({$typenames{$a}<=>$typenames{$b}} @names);
for my $name (@names) {
$typelist .= <<TYPELIST
$typenames{$name} - $name
TYPELIST
}
return <<USAGE;
$prog -i image -o outputfile [options]
Create a FLAC metadata picture block for use in Ogg/Vorbis comments.
-i image : input image (png or jpeg supported)
-o outputfile : output file name, may be as a tag file (default)
for vorbiscomment, the block (base64 encoded) or
the block (raw binary). See -writemode.
-desc "Description" : The description string for the picture block
(default empty)
-type N|name : Image type (default 0) may be numerical or one of
the allowed names below. See
<http://flac.sourceforge.net/format.html#metadata_block_picture>
for the full descriptions
$typelist
-write tag|block64|blockraw : Either write as a suitable tag for
vorbiscomment's -c option, the base 64 encoded
picture block only, or the block in raw format.
-v : verbose (reports block information)
-h
-help : Usage information
USAGE
}