Skip to content

Instantly share code, notes, and snippets.

@shoorick
Last active Aug 19, 2020
Embed
What would you like to do?
Image resizer and marker
*.komodoproject
.komodotools
resize-mark.LOCAL.pl

resize-mark

Make small pictures from big ones

Description

Make small pictures from big ones.

Usage

resize-mark.pl
    [ --color=text_color ]
    [ --gap=gap_between_text_chunks ]
    [ --name=author_name ]
    [ --prefix=small_pictures_filenames_prefix ]
    [ --quality=JPEG_quality ]
    [ --site=site_of_author ]
    [ --size=size_of_small_pictures ]
    files

Arguments

color – valid ImageMagick color: english word (white, black etc) or digital value (#RGB, #RGBA, #RRGGBB, #RRGGBBAA). Default value is #fff2 (⅞ transparent white).

gap – gap between text chunks in pixels. Default value is 10.

name – name of author, default value is name of current user.

prefix – small pictures filenames prefix, default value is small.

quality – JPEG quality — integer. Recommended value is 80.

Author

Alexander Sapozhnikov http://shoorick.ru/ shoorick@cpan.org

License

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

#!/usr/bin/perl -w
use strict;
=encoding utf-8
=head1 DESCRIPTION
Make small pictures from big ones.
=head1 USAGE
resize-mark.pl
[ --color=text_color ]
[ --gap=gap_between_text_chunks ]
[ --name=author_name ]
[ --prefix=small_pictures_filenames_prefix ]
[ --quality=JPEG_quality ]
[ --site=site_of_author ]
[ --size=size_of_small_pictures ]
files
=head2 Arguments
C<color> – valid ImageMagick color: english word (C<white>, C<black> etc)
or digital value (C<#RGB>, C<#RGBA>, C<#RRGGBB>, C<#RRGGBBAA>).
Default value is C<#fff2> (⅞ transparent white).
C<gap> – gap between text chunks in pixels. Default value is C<10>.
C<name> – name of author, default value is name of current user.
C<prefix> – small pictures filenames prefix, default value is C<small.>
C<quality> – JPEG quality — integer. Recommended value is C<80>.
=head1 AUTHOR
Alexander Sapozhnikov
L<< http://shoorick.ru/ >>
L<< E<lt>shoorick@cpan.orgE<gt> >>
=head1 LICENSE
This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
L<< https://github.com/shoorick/resize-mark >>
=cut
use Image::ExifTool ':Public';
use Image::Magick;
use File::Path qw( make_path );
use Getopt::Long;
use Pod::Usage qw( pod2usage );
# Constants
my %preferred_fonts = (
# Normal width
'date' => [ qw(
Open-Sans
DejaVuSans DejaVu-Sans DejaVu-Sans-Book
Bitstream-Vera-Sans BitstreamVeraSans
Verdana
) ],
# Narrow
'name' => [ qw(
Open-Sans-Condenced-Light
DejaVuSansC DejaVu-Sans-Condensed
Tahoma
) ],
# Narrow
'site' => [ qw(
Open-Sans-Bold
DejaVuSansB DejaVu-Sans-Bold
BitstreamVeraSansB
VerdanaB
TahomaB
) ],
);
map { $_ = '' } my (
$need_help, $need_manual, $verbose,
);
# Default values
my $color = '#fff2';
my $gap = 10;
my $name = (getpwuid $>)[6];
$name =~ s/,+$//;
my $prefix = 'small.';
my $site = 'shoorick.ru';
my $size = '50%';
my $pointsize = 12;
my $quality;
# Override with options
GetOptions(
'help|?' => \$need_help,
'manual' => \$need_manual,
'verbose' => \$verbose,
'color:s' => \$color,
'gap:i' => \$gap,
'name:s' => \$name,
'prefix:s' => \$prefix,
'site:s' => \$site,
'size:s' => \$size,
'pointsize:s' => \$pointsize,
'quality:i' => \$quality,
);
pod2usage('verbose' => 2)
if $need_manual;
# print help message when required arguments are omitted
pod2usage(1)
if $need_help
|| !@ARGV;
# Try to find suitable fonts
my $image = new Image::Magick;
my @available_fonts = $image->QueryFont();
my ( %seen, %fonts );
map { $seen{$_} = 1 } @available_fonts;
while ( my ( $scope, $list ) = each %preferred_fonts ) {
foreach ( @$list ) {
$fonts{ $scope } = $_
and last
if $seen{$_};
} # foreach
} # while
# Prefix contains slash and path doesn't exist
if ($prefix =~ m<^(.+)/[^/]*$> && ! -d $1) {
print "Create directory $1...\n";
make_path($1);
}
foreach my $file ( @ARGV ) {
my $info = ImageInfo($file, 'CreateDate');
my $date = $$info{'CreateDate'};
my $new_file_name = $file;
$new_file_name =~ s{([^/]+)$}{$prefix$1};
$date =~ s/^(\d{4}):(\d{2}):(\d{2}).*/$3.$2.$1/;
my $p = new Image::Magick or next;
my $rv;
$p->Read( $file );
$p->AutoOrient;
$p->Resize(
'geometry' => $size,
'filter' => 'Lanczos',
'blur' => 0.5,
);
my ( $width, $height ) = $p->Get('width', 'height');
my ( $x, $y ) = ( $width - $gap, $height - $gap );
$p->Set(
'pointsize' => $pointsize,
'fill' => $color,
);
$rv = $p->Annotate(
'font' => $fonts{'name'},
'text' => $name,
'rotate' => -90,
'x' => $x,
'y' => $y,
);
$y -= (
$p->QueryFontMetrics(
'font' => $fonts{'name'},
'text' => $name,
)
)[4] + $gap;
$rv = $p->Annotate(
'font' => $fonts{'site'},
'text' => $site,
'rotate' => -90,
'x' => $x,
'y' => $y,
);
$y -= (
$p->QueryFontMetrics(
'font' => $fonts{'site'},
'text' => $site,
)
)[4] + $gap;
$rv = $p->Annotate(
'font' => $fonts{'date'},
'text' => $date,
'rotate' => -90,
'x' => $x,
'y' => $y,
);
$rv = $p->AdaptiveSharpen(
'radius' => 0.5,
'sigma' => 0.5,
);
$p->Set( 'quality' => int $quality )
if $quality;
$p->Write($new_file_name);
print "$file - $date\n";
} # foreach
@shoorick

This comment has been minimized.

Copy link
Owner Author

@shoorick shoorick commented Sep 30, 2010

Меняет размер фотографий и подписывает их. Изменённые фотографии размещаются в том же каталоге, что исходные, их имена содержат префикс.

Использование

resize-mark.pl
    [ --color=цвет_текста ]
    [ --gap=отступ_между_фрагментами_текста ]
    [ --name=имя ]
    [ --prefix=префикс_имён_создаваемых_файлов ]
    [ --site=сайт ]
    [ --size=размер ]
    исходные_файлы

Параметры

color — цвет, допустимый в ImageMagick: английское название (white, black) либо числовое значение (#RGB, #RGBA, #RRGGBB, #RRGGBBAA). По умолчанию — #fff2 (белый прозрачностью ⅞).
gap — отступ между фрагментами текста в пикселях. По умолчанию — 10.
prefix — префикс имён маленьких фотографий, по умолчанию — small.
name — имя автора, по умолчанию совпадает с именем текущего пользователя.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment