View Code#!/usr/bin/perl
use strict;
#use warnings;
## Copyright 2020 CodeMacs.Com
## FREE open-source program to create overlay logo on video and image files
## as well as creating QR code images
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute,
# copies of the Software, and to permit persons to whom the Software
# is furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
# OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

# DEPENDENCIES:
# qrencode - QR code creation programhttps://fukuchi.org/works/qrencode/
# ffmpeg - video manipulation program
# ImageMagick - image manipulation program
# cgi-lib.pl - Steven E. Brenner's lightweight Perl Routines to Manipulate CGI input (included)

## INITIALIZE FILE AND USER STRUCTURE (Please edit to fit your server settings)
my $webdir='/home/account/www/improcess';## WEB FOLDER
my $webhtm='/improcess';## HTML WEB FOLDER
my $bsdir='/home/account/improcess';## NOT ACCESSIBLE FROM THE WEB FOLDER
my $coocdir='/home/account/cookies';## COOKIES FOLDER
my $user='Your_apache_web user';my $group='your_apache_group';
## Supporting files location:
# $webdir/d/index.cgi
# $webdir/bkg.cgi
# $webdir/cgi-lib.pl
# $webdir/zip.png
# Your Apache/NGINX web server has to handle index.cgi as default dir index file or
# change the extension accordingly but then reference in this software would need to be adjusted

my $remote_user = $ENV{REMOTE_USER};
unless($remote_user) {$remote_user = 'none';}
my $mess='';
## CREATE FOLDERS STRUCTURE OR CLEAN-UP BY ACCESSING THIS FILE AS: index.cgi?set or index.cgi?clean
if($ARGV[0]) {delete $ENV{'CONTENT_LENGTH'};
if($ARGV[0] =~ m/set/) {$mess = createdirs();}
if($ARGV[0] =~ m/clean/) {$mess = cleandirs();}
# CLEAN PROCEDURE COULD BE SET IN A CRONTAB BY CREATING A SEPARATE FILE TO CALL FROM CRON
} ## end input present

## DEFINE VARIABLES
our %in=();our %incfn=();my $rmltr='';
my $srv_Nme = $ENV{'SERVER_NAME'}; $srv_Nme =~ s/www\.//i; $srv_Nme =~ tr/A-Z/a-z/; $srv_Nme =~ s/^\.+//;my $domainc = $srv_Nme;
my $bcode='';my $expDate='';

## UNCOMMENT COOKIES PROCEDURE IF YOU WANT TO USE IT
#my %cookies = &getCookies;
#unless($cookies{buildit}) {
#if(-f "$coocdir/$ENV{'REMOTE_ADDR'}.txt") {$bcode = `cat $coocdir/$ENV{'REMOTE_ADDR'}.txt`;} else {$bcode=generate_randqr_string(28);}
#my $thisday = time; $thisday += (86400 * 2);$expDate = &set_exp($thisday);&setCookie("buildit", $bcode, $expDate, "$webhtm/", $domainc);
#} ## END NO BUILD IT PRESENT
#else {$bcode = $cookies{buildit};}
#unless(-f "$coocdir/$bcode.txt") {
#open(TXT,">$coocdir/$bcode.txt");print TXT "ip\t$ENV{'REMOTE_ADDR'}\nuser\t$ENV{REMOTE_USER}\n";close(TXT);
#} ## END NO COOKIE FILE PRESENT
#unless(-f "$coocdir/$ENV{'REMOTE_ADDR'}.txt") {open(TXT,">$coocdir/$ENV{'REMOTE_ADDR'}.txt");print TXT $bcode;close(TXT);} ## END IP FILE
## GOT COOKIES

## Hash for overlay placement in video files
my %fplace = ('br','overlay=W-w-XX:H-h-YY','bl','overlay=XX:H-h-YY','tr','overlay=W-w-XX:YY','tl','overlay=XX:YY');
my %gravity = ('br','southeast','bl','southwest','tr','northeast','tl','northwest');

## Run this code if input present
if($ENV{'CONTENT_LENGTH'}) {my $record=time;
if(-f "$webdir/cgi-lib.pl") {eval {require "$webdir/cgi-lib.pl"};
unless($@) {&ReadParse;}
} ## INPUT LIBRARY
my $filenamemain='';my $filenamelogo='';my $filenamezip='';
if($in{do} eq 'Create QR Code') {createqr();} ## Create QR code

if($in{'do'} eq 'Upload') { ## If upload present - run this code
if($in{mainimage}) {$incfn{mainimage} =~ s/ /\_/g;
if($incfn{mainimage}) {$filenamemain=$incfn{mainimage};} else {$filenamemain='tmp'}
$filenamemain = verifyfilename("$bsdir/orig/$filenamemain");
open(IMG,">$bsdir/orig/$filenamemain");print IMG $in{mainimage};close(IMG);
getexif("$bsdir/orig/$filenamemain",$record,'mainimage');
} ## END MAIN IMAGE PRESENT

if($in{logoimage}) {$record++;$incfn{logoimage} =~ s/ /\_/g;
if($incfn{logoimage}) {$filenamelogo=$incfn{logoimage};} else {$filenamelogo='tmp'}
$filenamelogo = verifyfilename("$bsdir/orig/$filenamelogo");
open(IMG,">$bsdir/orig/$filenamelogo");print IMG $in{logoimage};close(IMG);
getexif("$bsdir/orig/$filenamelogo",$record,'logoimage');
} ## END LOGO IMAGE PRESENT

## PROCESS ZIP FILE IMAGES UPLOAD
if($in{zipimage}) {$record++;$incfn{zipimage} =~ s/ /\_/g;
if($incfn{zipimage}) {$filenamezip=$incfn{zipimage};} else {$filenamezip=$record.'.tmp.zip'}
unless(-d "$bsdir/tempzip/$remote_user") {`mkdir -p $bsdir/tempzip/$remote_user`;`chown $user\:$group $bsdir/tempzip/$remote_user`;}
$filenamezip = verifyfilename("$bsdir/tempzip/$filenamezip");$filenamezip = verifyfilename("$bsdir/tempzip/$remote_user/$filenamezip");
open(ZIP,">$bsdir/tempzip/$filenamezip");print ZIP $in{zipimage};close(ZIP);
my $filerec = unzipfiles("$bsdir/tempzip/$filenamezip");
if(-d $filerec) {my @flprts=split(/\//,$filerec);my $rcsv = pop(@flprts);
my @fimg = glob("$filerec/*");my $nofiles=@fimg;my %imgrecord=();my $nofimgs=0;
my $frec=$filenamezip;$frec =~ s/\.\w{2,4}$//;`mv $bsdir/tempzip/$filenamezip $bsdir/tempzip/$remote_user/$filenamezip`;
open(IMF,">$bsdir/tempzip/$remote_user/$rcsv.txt");
print IMF "\tZIP file\t$bsdir/tempzip/$remote_user/$filenamezip\n\tIMG Dir\t$bsdir/tempzip/$remote_user/$rcsv\n";
foreach my $im (@fimg) { #####
if(-d $im) {`rm -rf $im`;next;}
if($im =~ m/ /) {my $tim=$im;$tim =~ s/ /\_/g;my $tres = `mv "$im" $tim`;$im=$tim;}
my $imgclean = $im;$imgclean =~ s#$filerec/##;
my $imdata = `exiftool $im`;$imdata =~ s/\r//g;$imdata =~ s#(.*?)(\s+)(\:)(\s)(.*?)\n#$1\t$5\n#g;my @exdata = split(/\n/,$imdata);
foreach my $l (@exdata) {
my($key,$data) = split(/\t/,$l);if($key && $data) {$imgrecord{$imgclean}{$key}=$data;}
} ## FOREACH LINE END
unless($imgrecord{$imgclean}{'MIME Type'} =~ m/image/) {delete $imgrecord{$imgclean};`rm -rf $im`;next;}
my $width='';my $height='';$nofimgs++;
if($nofimgs == 1) {`convert $im -resize 120x $webdir/logo/zipimage.$rcsv.jpg`;} ## CREATE THUMB
if($imgrecord{$imgclean}{'Image Width'} && $imgrecord{$imgclean}{'Image Height'}) {
$width=$imgrecord{$imgclean}{'Image Width'};$height=$imgrecord{$imgclean}{'Image Height'};
}
elsif($imgrecord{$imgclean}{'Exif Image Width'} && $imgrecord{$imgclean}{'Exif Image Height'}) {
$width=$imgrecord{$imgclean}{'Exif Image Width'};$height=$imgrecord{$imgclean}{'Exif Image Height'};
}
if($width && $height) {print IMF "$imgclean\tWidth\t$width\n$imgclean\tHeight\t$height\n";}
} ## FOREACH FILE END ########
foreach my $i (sort keys (%imgrecord)) {
foreach my $dt (sort keys %{$imgrecord{$i}}) {print IMF "$i\t$dt\t$imgrecord{$i}{$dt}\n";}
} ## FOREACH IMG EXIF DATA END
close(IMF);
if($nofimgs > 0) {$mess = "\n<p style=\"color:#00d000;font-weight:bold;\">ZIP file was successfully extracted with $nofimgs images.</p>";}
else {$mess = "\n<p style=\"color:#d00000;font-weight:bold;\">ZIP file was NOT processed as no images were found in ZIP root. Please include all images in root of a ZIP file.</p>";
`rm -rf $filerec`;`rm $bsdir/tempzip/$remote_user/$rcsv.txt`;`rm -f $bsdir/tempzip/$remote_user/$filenamezip`;
} ## END NO IMAGES COLLECTED
} ## END DIR RETURNED
else {`rm $bsdir/tempzip/$filenamezip`;$mess = "\n<p style=\"color:#d00000;\">ZIP file had errors and no files were unzipped</p>";} ## END NO DIR RETURNED
} ## END UPLOAD ZIP OF IMAGES
} ## END IF UPLOAD

if($in{'do'} eq 'Delete selected logo' && $in{'logo'}) {$mess=deletelogo($in{'logo'});$mess = "\n<p style=\"color:#d00000;\">$mess</p>";}
if($in{'do'} eq 'Delete selected video' && $in{'videoimage'}) {$mess=deletevideo($in{'videoimage'});$mess = "\n<p style=\"color:#d00000;\">$mess</p>";}
if($in{'do'} eq 'Preview Logo') {makecomb();}
if($in{'do'} eq 'Build and Download') {finalbuild();}
} ## END IF DATA PRESENT

sub finalbuild {
unless($in{'videoimage'} && $in{'logo'}) {$mess = "\n<p style=\"color:#d00000;\">Please select Video/Image and a Logo!</p>";return;}
if($in{'videoimage'} =~ m/^zip/) {$in{'videoimage'} =~ s/^zip\.//;createzipfile($in{'videoimage'});} ## ZIP ARCHIVE END
my($mftype,$mfile,$mwidth,$mheight,$mfps,$mvdur,$vbitrate)=getcmbdata($in{'videoimage'});
my($lftype,$lfile,$lwidth,$lheight,$lfps,$lvdur,$ibitrate)=getcmbdata($in{'logo'});
my @tmm = split(/\//,$mfile);my $wrfl = pop(@tmm);
$wrfl =~ s/\.(\w{3,4})$//;my $fextention=$1;my $writing=time;my $fremove='';
my $finwrite=$wrfl;$finwrite =~ s/(\w+\.)(.*)/$2/;
#print "Content-type: text/html\n\n$finwrite $fextention FPS: $mfps DUR: $mvdur/$totsec Frames: $totframes<br />$mftype $lftype";exit(0);
$in{width} =~ s/\D//g;$in{height} =~ s/\D//g;
if($in{width} == $lwidth) {$in{width}='';}
if($in{height} == $lheight) {$in{height}='';}
if($in{width} || $in{height}) {my $sspr='x';
`convert $lfile -resize $in{width}$sspr$in{height} $bsdir/temp/$writing.png`;$lfile="$bsdir/temp/$writing.png";$fremove=1;
} ## END WIDTH OR HEIGHT PRESENT
$in{arotate} =~ s/\D//g;my $actrotate=0;
if($in{rotate} > 360) {$in{rotate} = 1;}
if($in{arotate} > 360 || $in{arotate} < 1) {$in{arotate} = '';}
if($in{arotate}) {$actrotate=$in{arotate};$in{rotate}=0;}
else {
if($in{rotate} > 1) {$actrotate=$in{rotate};}
} ## END NOT ARBITRARY ROTATE PRESENT
if($actrotate) {
`convert -background none -rotate $actrotate $lfile $bsdir/temp/$writing.r.png`;$lfile="$bsdir/temp/$writing.r.png";$fremove=1;
} ## END IF ROTATE
unless($in{opacity}) {$in{opacity}=30;}
unless($in{xoffset}) {$in{xoffset}=20;}
unless($in{yoffset}) {$in{yoffset}=20;}

if($mftype eq 'image') { ######### I
`composite -dissolve $in{opacity}% -gravity $gravity{$in{placement}} -geometry +$in{xoffset}+$in{yoffset} $lfile $webdir/logo/$wrfl.jpg $webdir/src/$finwrite.$fextention`;
`convert $webdir/src/$finwrite.$fextention -resize 120x $webdir/src/$finwrite.sm.$fextention`;my $title='Download your image file';
my $htmlpg = "<p>Please \"Right-Click\" on a thumbnail below and select \"Save As\", \"Download Linked file As\" or similar from the menu to save file to your computer or phone.</p>
<p><a href=\"src/$finwrite.$fextention\"><img src=\"src/$finwrite.sm.$fextention\" width=\"120\"></a></p>
<p>Thank you!</p>";
if($fremove) {`rm -rf $bsdir/temp/*`;}
my $rmltr = "$webdir/src/$finwrite.$fextention\n$webdir/src/$finwrite.sm.$fextention\n";writeremove($rmltr);
preprintpage($title,$htmlpg);
} ## END IMAGE ################### I

my $vopacity=$in{opacity} / 100;$vopacity = sprintf("%0.2f",$vopacity);
my($dhr,$dmn,$dsec) = split(/ /,$mvdur);my $totsec=0;$dsec = sprintf("%0.0f",$dsec);
if($dhr > 0) {my $hrsec=$dhr*3600;$totsec += $hrsec;}
if($dmn > 0) {my $mnsec=$dmn*60;$totsec += $mnsec;}
if($dsec > 0) {$totsec += $dsec;}
my $totframes = $totsec * $mfps;my $estimate = $totframes / 4;$estimate = sprintf("%0.0f",$estimate);
my $delay=parse_duration($estimate);

my $overl = $fplace{$in{placement}};$overl =~ s#XX#$in{xoffset}#;$overl =~ s#YY#$in{yoffset}#;
if($vbitrate) {$vbitrate += 1000;$vbitrate = " -b:v ".$vbitrate."k -maxrate ".$vbitrate."k -bufsize ".$vbitrate."k";}

unless($totframes > 1000) {
`ffmpeg -y -i $mfile -i $lfile -filter_complex "[1]format=bgra,colorchannelmixer=aa=$vopacity,rotate=0:c=black\@0:ow=rotw(0):oh=roth(0)[image];[0][image]$overl"$vbitrate $webdir/src/$finwrite.$fextention`;
`ffmpeg -y -i $webdir/src/$finwrite.$fextention -vf "select=eq(n\\,30)" -vframes 1 $webdir/src/$finwrite.sm1.jpg`;
`convert $webdir/src/$finwrite.sm1.jpg -resize 120x $webdir/src/$finwrite.sm.jpg`;
`rm $webdir/src/$finwrite.sm1.jpg`;
my $title='Download your video file';
my $htmlpg = "<p>Please \"Right-Click\" on a thumbnail below and select \"Save As\", \"Download Linked file As\" or similar from the menu to save file to your computer or phone.</p>
<p><a href=\"src/$finwrite.$fextention\"><img src=\"src/$finwrite.sm.jpg\" width=\"120\"></a></p>
<p>Thank you!</p>";
if($fremove) {`rm -rf $bsdir/temp/*`;}
my $rmltr = "$webdir/src/$finwrite.sm.jpg\n$webdir/src/$finwrite.$fextention\n";writeremove($rmltr);
preprintpage($title,$htmlpg);exit(0);
} ## END SHORT VIDEO
## CHECK THE RUNNING VIDEO EDIT PROGRAM RUN FIRST -- IF NOT RUNNING - PROCESS THE FILE
else {my $program='/usr/bin/perl $webdir/bkg.cgi';my $foundit = 0;
open (IN, "ps axw |");while (<IN>) {
if(/$program/) {$foundit = 1;last;}
}close IN; ## WHILE END
if($foundit) {my $title='Program already running';
my $htmlpg = "<p>Server is currently processing video. Only one process allowed at the time. Please re-load this page when program finishes.</p>
<p>Thank you!</p>";preprintpage($title,$htmlpg);exit(0);} ## END PROGRAM IS RUNNING ALREADY

my @srfl = split(/\//,$lfile);my $mvtofl = pop(@srfl);@srfl=();`cp $lfile $bsdir/temp1/file.$mvtofl`;$lfile="$bsdir/temp1/file.$mvtofl";
my $rprocess = generate_randqr_string(14);
open(TXD,">$bsdir/process.$rprocess.txt");
print TXD "Total frames\t$totframes\n";
print TXD "Length\t$totsec seconds\n";
print TXD "FPS\t$mfps\n";
print TXD "process\tffmpeg -y -i $mfile -i $lfile -filter_complex \"[1]format=bgra,colorchannelmixer=aa=$vopacity,rotate=0:c=black\@0:ow=rotw(0):oh=roth(0)[image];[0][image]$overl\"$vbitrate $webdir/src/$finwrite.$fextention\n";
print TXD "write\t$finwrite link $bsdir/src/$finwrite.$fextention\n";
print TXD "process\tffmpeg -y -i $webdir/src/$finwrite.$fextention -vf \"select=eq(n\\,30)\" -vframes 1 $webdir/src/$finwrite.sm1.jpg\n";
print TXD "process\tconvert $webdir/src/$finwrite.sm1.jpg -resize 120x $webdir/src/$finwrite.sm.jpg\n";
print TXD "write\t$finwrite img $bsdir/src/$finwrite.sm.jpg\n";
print TXD "process\trm $webdir/src/$finwrite.sm1.jpg\n";
print TXD "process\trm $bsdir/temp1/file.$mvtofl\n";
close(TXD);
if($fremove) {`rm -rf $bsdir/temp/*`;}
my $pid = fork;
if($pid == 0) { ##
open STDIN, "</dev/null";open STDOUT, ">/dev/null";open STDERR, ">/dev/null";
`/usr/bin/perl $webdir/bkg.cgi $rprocess $remote_user`;exit(0);
} ## FORK THE PROCESS IF PID ###

my $title='We\'re processing your request';
my $htmlpg = "<p>Your video file is too long to process it immediately, so it was submitted for processing to our server.<br />
Once program finishes processing you will be notified by e-mail, or you can go to:<br />
<a href=\"$webhtm/d/\">Download page</a> in roughly about $delay</p>
<p>Thank you!</p>";
my $rmltr = "$webdir/src/$finwrite.sm.jpg\n$webdir/src/$finwrite.$fextention\n";writeremove($rmltr);
preprintpage($title,$htmlpg);
exit(0);
} ## END LONG VIDEO
if($fremove) {`rm -rf $bsdir/temp/*`;}my $htmlpg = 'Process finished';my $title='Finished';
my $rmltr = "$webdir/src/$finwrite.sm.jpg\n$webdir/src/$finwrite.$fextention\n";writeremove($rmltr);
preprintpage($title,$htmlpg);
} ## END MAKE FINAL FILE

sub domultiple { ######
my $srcfile=shift;
if(-f "$bsdir/tempzip/$remote_user/$srcfile.txt") {my $d = `cat $bsdir/tempzip/$remote_user/$srcfile.txt`;my @ifiles=split(/\n/,$d);$d='';
my %timgdata=();
foreach my $l (@ifiles) {
my($im,$key,$val) = split(/\t/,$l);unless($im && $key && $val) {next;}$timgdata{$im}{$key}=$val;
} ## FOREACH END
@ifiles = sort keys(%timgdata);my $imf = shift(@ifiles);my %dtvd=();my $bitrate='';
($dtvd{MIME},$dtvd{TYPE}) = split(/\//,$timgdata{$imf}{'MIME Type'});$dtvd{file}="$bsdir/tempzip/$remote_user/$srcfile/$imf";
$mess = "\n<p>$dtvd{MIME} $dtvd{file} $timgdata{$imf}{Width} $timgdata{$imf}{Height}</p>";
return($dtvd{MIME},$dtvd{file},$timgdata{$imf}{Width},$timgdata{$imf}{Height},$dtvd{'Frame rate'},"$dtvd{'Video duration hr'} $dtvd{'Video duration minutes'} $dtvd{'Video duration seconds'}",$bitrate);
} ## END SOURCE FILE PRESENT
else {$mess = "\n<p style=\"color:#d00000;\">Unable to create images - source file missing</p>";return;}
} ## END DO MULTIPLE ##

sub makecomb {my $addstr='';
unless($in{'videoimage'} && $in{'logo'}) {$mess = "\n<p style=\"color:#d00000;\">Please select Video/Image and a Logo!</p>";return;}
my($ftypev,$mfile,$mwidth,$mheight,$mfps,$mvdur,$vbitrate);
if($in{'videoimage'} =~ m/^zip/) {$in{'videoimage'} =~ s/^zip\.//;($ftypev,$mfile,$mwidth,$mheight,$mfps,$mvdur,$vbitrate)=domultiple($in{'videoimage'});
$addstr='zip.';
} else {
($ftypev,$mfile,$mwidth,$mheight,$mfps,$mvdur,$vbitrate)=getcmbdata($in{'videoimage'});}
my($ftype,$lfile,$lwidth,$lheight,$lfps,$lvdur,$ibitrate)=getcmbdata($in{'logo'});
my @tmm = split(/\//,$mfile);my $wrfl = pop(@tmm);
$wrfl =~ s/\.\w{3,4}$//;my $writing=time;my $fremove='';
$in{width} =~ s/\D//g;$in{height} =~ s/\D//g;
if($in{width} == $lwidth) {$in{width}='';}
if($in{height} == $lheight) {$in{height}='';}
if($in{width} || $in{height}) {my $sspr='x';
`convert $lfile -resize $in{width}$sspr$in{height} $bsdir/temp/$writing.png`;$lfile="$bsdir/temp/$writing.png";$fremove=1;
} ## END WIDTH OR HEIGHT PRESENT
$in{arotate} =~ s/\D//g;my $actrotate=0;
if($in{rotate} > 360) {$in{rotate} = 1;}
if($in{arotate} > 360 || $in{arotate} < 1) {$in{arotate} = '';}
if($in{arotate}) {$actrotate=$in{arotate};$in{rotate}=0;}
else {
if($in{rotate} > 1) {$actrotate=$in{rotate};}
} ## END NOT ARBITRARY ROTATE PRESENT
if($actrotate) {
`convert -background none -rotate $actrotate $lfile $bsdir/temp/$writing.r.png`;$lfile="$bsdir/temp/$writing.r.png";$fremove=1;
} ## END IF ROTATE
unless($in{opacity}) {$in{opacity}=30;}
unless($in{xoffset}) {$in{xoffset}=20;}
unless($in{yoffset}) {$in{yoffset}=20;}
#print "Content-type: text/html\n\n$mfile<br />\n$mwidth<br />\n$mheight<br />\n$lfile<br />\n$lwidth<br />\n$lheight";exit(0);
my $readmain="$webdir/logo/$wrfl.jpg";if($addstr eq 'zip.') {$readmain=$mfile;}
`composite -dissolve $in{opacity}% -gravity $gravity{$in{placement}} -geometry +$in{xoffset}+$in{yoffset} $lfile $readmain $webdir/src/$wrfl.jpg`;
`convert $webdir/src/$wrfl.jpg -resize 120x $webdir/src/$wrfl.sm.jpg`;my $title='Preview your composition';
if($fremove) {`rm -rf $bsdir/temp/*`;}
my $rmltr = "$webdir/src/$wrfl.jpg\n$webdir/src/$wrfl.sm.jpg\n";writeremove($rmltr);
my @types = qw(br bl tr tl);my $pselect='';my $chked='';
my %tconv=('br','Bottom Right','bl','Bottom Left','tr','Top Right','tl','Top Left');
my %rotate = ('90','90 degrees CW','180','180 degrees','270','90 degrees CCW','1','No Rotation');
unless($in{rotate}) {$in{rotate}=1;}
foreach my $k (@types) {$chked='';
if($k eq $in{placement}) {$chked=' checked';}
$pselect .= "<input type=\"radio\" name=\"placement\" value=\"$k\"$chked> $tconv{$k}\n";
} ## FOREACH END
chomp $pselect;$pselect =~ s#\n#<br />\n#g;my $rchk='';my $rsel='';
foreach my $r (sort num keys (%rotate)) {
if($r == $in{rotate}) {$rchk=' checked';}
$rsel .= "<input type=\"radio\" name=\"rotate\" value=\"$r\"$rchk> $rotate{$r}\n";$rchk='';
} ## FOREACH ROTATE END
$rsel .= "<input type=\"text\" name=\"arotate\" value=\"$in{arotate}\" size=\"4\"> <span class=\"tooltip\"><span class=\"tooltiptext\">Enter rotation in degrees as following:<br />90: would turn logo 90 degrees clockwise<br />270: would turn logo 90 degrees counter clockwise.<br /><br />Anything between 1 and 360 would turn your logo.</span>arbitrary</span>";$rsel =~ s#\n#<br />\n#g;
my $pgsrc = "<form method=\"post\" action=\"$webhtm/\"><p>Please preview the full size image built-up on input images by clicking on a thumbnail.<br />
Use options below to change Logo placement.</p>
<a href=\"src/$wrfl.jpg\"><img src=\"src/$wrfl.sm.jpg\"></a>
<p>Settings used:<br />
<table><tr><td bgcolor=\"#f3f3f3\"><table cellpadding=\"5\" width=100%>
<tr bgcolor=\"#ffffff\"><td>Opacity:</td><td><input type=\"text\" name=\"opacity\" value=\"$in{opacity}\" size=\"4\">\%</td></tr>
<tr bgcolor=\"#ffffff\"><td>Horizontal margin:</td><td><input type=\"text\" name=\"xoffset\" value=\"$in{xoffset}\" size=\"4\"> pixels</td></tr>
<tr bgcolor=\"#ffffff\"><td>Vertical margin:</td><td><input type=\"text\" name=\"yoffset\" value=\"$in{yoffset}\" size=\"4\"> pixels</td></tr>
<tr bgcolor=\"#ffffff\"><td valign=\"top\">Logo placement:</td><td>$pselect</td></tr>
<tr bgcolor=\"#ffffff\"><td valign=\"top\">Rotate Logo:</td><td>$rsel</td></tr>
<tr bgcolor=\"#ffffff\"><td valign=\"top\">Resize Logo:</td><td>Current size: width $lwidth pixels, height $lheight pixels<br />
<span class=\"tooltip\"><span class=\"tooltiptext\">Enter either width or height<br />and program will resize it<br />with original aspect ratio.</span>New Size</span>:
<input type=\"text\" name=\"width\" value=\"$in{width}\" size=\"4\" placeholder=\"$lwidth\"> X <input type=\"text\" name=\"height\" value=\"$in{height}\" size=\"4\" placeholder=\"$lheight\"></td></tr>
<tr bgcolor=\"#ffffff\"><td valign=\"top\"><input type=\"submit\" value=\"Preview Logo\" name=\"do\" style=\"background:#53de47;\"></td>
<td><input type=\"submit\" value=\"Build and Download\" name=\"do\" style=\"background:#6f87ff;\"><br />
<span style=\"color:#ff3f3a;\">It may take a few minutes to build your video<br />depending on its length and resolution.</span></td></tr>
</table></td></tr></table></p><input type=\"hidden\" name=\"videoimage\" value=\"$addstr$in{videoimage}\"><input type=\"hidden\" name=\"logo\" value=\"$in{logo}\"></p>
</form>$mess";
preprintpage($title,$pgsrc);
} ## END GET PREVIEW

sub preprintpage {
my($title,$html) = @_;
print "Content-type: text/html\n\n";
print <<EOH;
<html>
<head>
<title>$title</title>
<meta name="viewport" content="width=device-width, initial-scale=1">
<link rel="stylesheet" type="text/css" href="all.css" media="screen"/>
<style>input[type=text]{width:auto;}</style>
</head>
<body>
<h1>$title</h1>
$html
<hr size="1" width="30%" align="left">
<p><a href=\"$webhtm/\">Back to Main Page</a></p>
</body>\n</html>
EOH
exit(0);
} ## END PRE PRINT PAGE

sub getcmbdata {
my $delimg=shift;$delimg =~ s#^(.*?)\.##;$delimg =~ s/\.\w{3,4}$//;my %dtvd=();
my $width='';my $height='';my $bitrate='';
if(-f "$bsdir/records/$delimg.txt") {
my $fnd = `cat $bsdir/records/$delimg.txt`;my @rddta = split(/\n/,$fnd);$fnd='';
foreach my $l (@rddta) {my($key,$val) = split(/\t/,$l);if($key && $val) {$dtvd{$key}=$val;}} # FOREACH
}
if($dtvd{role} eq 'mainimage') {
if($dtvd{'Video resolution'}) {my $spr='x';($width,$height) = split(/$spr/,$dtvd{'Video resolution'});
if($dtvd{'Bit rate'}) {$bitrate=$dtvd{'Bit rate'};}
}
else {
if($dtvd{MIME} eq 'image') {my $image = `anytopnm $dtvd{file}`;($width,$height) = pnmsize($image);$image='';}
}
} ## END MAIN IMAGE
elsif($dtvd{role} eq 'logoimage') {
if($dtvd{MIME} eq 'image') {my $image = `anytopnm $dtvd{file}`;($width,$height) = pnmsize($image);$image='';}
} ## END IF LOGO
return($dtvd{MIME},$dtvd{file},$width,$height,$dtvd{'Frame rate'},"$dtvd{'Video duration hr'} $dtvd{'Video duration minutes'} $dtvd{'Video duration seconds'}",$bitrate);
} ## END GET COMBINED FILES DATA

my $logolist='';my $selecti=' checked';
my @all = glob("$bsdir/logo/*");
my $spr='<tr bgcolor="#ffffff"><td valign="top">or choose <b>Logo</b> from the list:</td>';
foreach my $lf (@all) {
my $d = `cat $lf`;my($file,$size) = split(/\t/,$d);$file =~ s#$bsdir/logoimage/#logo/#;my $fimg=$file;$fimg =~ s#\.\w{3,4}$#\.jpg#;
$size =~ s#(.*?) (.*)#Width: $1 Height: $2#;$size = "<br />$size";
$logolist .= "$spr<td valign=\"top\"><input type=\"radio\" name=\"logo\" value=\"$file\"$selecti></td><td> </td><td><img src=\"$fimg\" class=\"timg\">$size</td></tr>\n";
$spr='<tr bgcolor="#ffffff"><td></td>';
} ## FOREACH LOGO FILES
if($logolist) {chomp $logolist;$logolist .= 'LST';$selecti='';
my $sbm='<br /><input type="submit" value="Delete selected logo" name="do" style="background:#ff2813;">';
$logolist =~ s#</td></tr>LST#$sbm</td></tr>#;}

my $videolist='';my $selectv=' checked';
@all = glob("$bsdir/orig/*");
$spr='<tr bgcolor="#ffffff"><td valign="top">or choose <b>Video/Image</b> from the list:</td>';
foreach my $f (@all) {my $fr = $f;$fr =~ s#$bsdir/orig/#$bsdir/records/#;$fr =~ s#\.\w{3,4}$#\.txt#;
my %read = readdata($fr);my $img='';$fr =~ s#$bsdir/records/##;$fr =~ s#\.\w{3}$##;my $duration='';
if($read{'Video duration seconds'}) {
$duration = "<br />Duration: <b>$read{'Video duration hr'} HR $read{'Video duration minutes'} Min $read{'Video duration seconds'} Sec</b>";
}
if($read{'Video resolution'}) {$read{'Video resolution'} = "Resolution: <b>$read{'Video resolution'}</b>";}
if(-f "$webdir/logo/$fr.sm.jpg") {$img = "<img src=\"$webhtm/logo/$fr.sm.jpg\" class=\"timg\"><br />File Type: <b>$read{MIME}</b></br />";}
$videolist .= "$spr<td valign=\"top\"><input type=\"radio\" name=\"videoimage\" value=\"$fr\"$selectv></td><td> </td><td>$img$read{'Video resolution'}$duration</td></tr>\n";
$spr='<tr bgcolor="#ffffff"><td></td>';$selectv='';
} ## FOREACH END

my $ziplist='';my $zipsel='';my $zipimage='';$spr='<tr bgcolor="#ffffff">ZIP file<td></td>';
my @allz = glob("$bsdir/tempzip/$remote_user/*");
foreach my $zf (@allz) { ###
unless($zf =~ m/\.txt$/) {next;}my $img='';
$zf =~ s#$bsdir/tempzip/$remote_user/##;$zf =~ s/\.txt$//;
if(-f "$webdir/logo/zipimage.$zf.jpg") {$img = "<img src=\"$webhtm/logo/zipimage.$zf.jpg\" class=\"timg\">";}
$videolist .= "$spr<td valign=\"top\"><input type=\"radio\" name=\"videoimage\" value=\"zip.$zf\"$selectv></td><td> </td><td>$img</td></tr>\n";
$selectv='';
} ## FOREACH ZIP END #######

if($videolist) {chomp $videolist;$videolist .= 'END';
my $sbm='<br /><input type="submit" value="Delete selected video" name="do" style="background:#ff2813;">';
$videolist =~ s#</td></tr>END#$sbm</td></tr>#;
} ## END VIDEO LIST PRESENT

my $dnlLink='';
if(-f "$bsdir/download.$remote_user.txt") {$dnlLink = "<span class=\"tlnkm\"><a href=\"d/\">Download Files</a></span>";}

my $fpreview='';
if(($ziplist || $videolist) && $logolist) {$fpreview='<tr bgcolor="#f8f8f8"><td valign="top">Place logo at:</td><td colspan="3"><input type="radio" name="placement" value="br" checked> Bottom Right<br />
<input type="radio" name="placement" value="bl"> Bottom Left<br />
<input type="radio" name="placement" value="tr"> Top Right<br />
<input type="radio" name="placement" value="tl"> Top Left</td></tr>
<tr bgcolor="#ffffff"><td align="right"><b>Add Logo to your video/image -></b></td><td colspan="3"><input type="submit" value="Preview Logo" name="do" style="background:#53de47;"></td></tr>';}
unless($in{qrmargin}) {$in{qrmargin}=3;}
my $pgrefr='';
if($in{do}) {$pgrefr = "     <a href=\"$webhtm/\">Refresh Page</a>";}
print "Content-type: text/html\n\n";
print <<EOH;
<html>
<head>
<title>Video and Image files</title>
<meta name="viewport" content="width=device-width, initial-scale=1">
<link rel="stylesheet" type="text/css" href="all.css" media="screen"/>
</head>
<body>
<h1>Video and Image files processing</h1>$dnlLink$mess
<p>Create Watermarked video/image file.$pgrefr<br />\nCombine Video/Image file with your Logo file below - you'd have to upload them first.</p>
<form method="post" action="$webhtm/" enctype="multipart/form-data">
<p><table>
<tr><td bgcolor="#f3f3f3"><table cellpadding="5">
<tr bgcolor="#ffffff"><td><span class="tooltip"><span class="tooltiptext">Video accepted in almost any format:<br />MOV, MP4, AVI etc.<br />Images also accepted in any image format:<br />TIFF, JPG, PNG, GIF..</span>Upload file (image or video)</span> for processing:</td><td colspan="3"><input type="file" name="mainimage"> <input type="submit" value="Upload" style="background:#89a0ff;" name="do"></td></tr>
<tr bgcolor="#ffffff"><td><span class="tooltip"><span class="tooltiptext">ZIP all your image files and upload<br />ZIP-ed images accepted in any image format:<br />TIFF, JPG, PNG, GIF..</span>Butch upload images in ZIP file</span> for processing:</td><td colspan="3"><input type="file" name="zipimage"> <input type="submit" value="Upload" style="background:#89a0ff;" name="do"></td></tr>$videolist
<tr bgcolor="#f8f8f8"><td><span class="tooltip"><span class="tooltiptext">Choose PNG file with transparency for Logo.<br />In JPEG image -- white color will become transparent.<br />Make Logo less than 25% of the video width.<br />Logo can be re-sized in preview.</span>Upload <b>Logo</b> file</span> to use with file above:</td><td colspan="3"><input type="file" name="logoimage"> <input type="submit" value="Upload" style="background:#89a0ff;" name="do"></td></tr>$logolist
$fpreview
<tr><td colspan="4" bgcolor="#f8f8f8">it may take some time to upload your files.. please be patient.</td></tr>
</table></td></tr></table></p>
<hr size="1" width="50%" align="left">
<h3>Create QR code</h3>
<p><input type="text" name="qrtext" placeholder="Enter text for QR Code" value="$in{qrtext}" style="width:60%;margin-right:1vw">
<input type="submit" value="Create QR Code" style="background:#ffbe0a;" name="do"><br />
Margin: <input type="text" name="qrmargin" value="$in{qrmargin}" style="width:2em;margin-left:1vw"> <span class="tooltip"><span class="tooltiptext">Margin width around the image.</span>pixels</span></p>
?   <span class="tooltip"><span class="tooltiptext">If full URL entered first and then a small description text - it will be properly formatted in QR Code readers.<br /><br />
If URL entered last - on some QR Code readers additional text will not be visible<br /><br />
It is best if "Full URL" includes all parts as: </span>QR Code Help</span>
</form>
</body>\n</html>
EOH
exit(0);

sub getexif {
my $f = shift;my $rec=shift;my $imrole=shift;my $dodelete='';
my $fn = $f;$fn =~ s#$bsdir/orig/##;
unless(-f $f) {return;}
my $ext='';my $mime='';my $mtpe='';
my $exifdata = `exiftool $f | grep 'Type'`;
my @read = split(/\n/,$exifdata);$exifdata='';
foreach my $l (@read) {
my($ref,$dat) = split(/\:/,$l);$dat =~ s/^\s+//;$dat =~ s/\s+$//;
if($ref =~ m/File/) {$ext=$dat;$ext =~ tr/A-Z/a-z/;}
if($ref =~ m/MIME/) {$mime=$dat;($mime,$mtpe) = split(/\//,$mime);}
} ## FOREACH LINE END
$ext =~ s/jpeg/jpg/;
open(TXR,">>$bsdir/records/$rec.txt");
print TXR "role\t$imrole\n";
if($mime) {print TXR "MIME\t$mime\nMIME type\t$mtpe\n";
} ## END MIME PRESENT
if($ext) {print TXR "File Extension\t$ext\n";
if($imrole =~ m/main/) {`mv "$f" $bsdir/orig/$imrole.$rec.$ext`;print TXR "file\t$bsdir/orig/$imrole.$rec.$ext\n";
if($mime =~ m/video/i) {
my $mvlist = `ffmpeg -i $bsdir/orig/$imrole.$rec.$ext 2>\&1`;
#my $vres = `ffmpeg -i $bsdir/orig/$imrole.$rec.$ext 2>\&1 | grep Video: | grep -Po '\\d{3,5}x\\d{3,5}'`;$vres =~ s/\n|\r//g;
#my $dur = `ffmpeg -i $bsdir/orig/$imrole.$rec.$ext 2>\&1 | grep Duration: | grep -Po '\\d{2}:\\d{2}:\\d{2}.\\d{2}'`;$dur =~ s/\n|\r//g;

$mvlist =~ s#Video:(.*?)(\d{3,5}x\d{3,5})#$&#;my $vres = $2;$vres =~ s/\n|\r//g;
$mvlist =~ s#Duration:(.*?)(\d{2}:\d{2}:\d{2}.\d{2})#$&#;my $dur=$2;$dur =~ s/\n|\r//g;
$mvlist =~ s#Duration:(.*?)bitrate: (\d+) k(.*?)#$&#;my $bitrate=$2;$bitrate =~ s/\n|\r//g;
$mvlist =~ s#Video:(.*?)(\d{2}\.\d{2}|\d{2,3}) fps#$&#;my $frmrt=$2;$frmrt =~ s/\n|\r//g;

my($hr,$min,$sec) = split(/\:/,$dur);#$sec =~ s#(\d{2})\.(\d{2})#$1#;
#my $frmrt = `ffmpeg -i $bsdir/orig/$imrole.$rec.$ext 2>\&1 | grep Video: | grep -Po '\\d{2}\\.\\d{2}|\\d{2,3} fps'`;$frmrt =~ s/\n|\r//g;$frmrt =~ s# fps##i;

print TXR "Video resolution\t$vres\nVideo duration hr\t$hr\nVideo duration minutes\t$min\nVideo duration seconds\t$sec\nFrame rate\t$frmrt\nBit rate\t$bitrate\n";
`ffmpeg -i $bsdir/orig/$imrole.$rec.$ext -vf "select=eq(n\\,30)" -vframes 1 $bsdir/orig/$imrole.$rec.tmp.jpg`;
`convert -density 72 $bsdir/orig/$imrole.$rec.tmp.jpg -quality 50 -flatten -colorspace RGB +repage $webdir/logo/$imrole.$rec.jpg`;
`convert -density 72 $bsdir/orig/$imrole.$rec.tmp.jpg -resize 120x -quality 50 -flatten -colorspace RGB +repage $webdir/logo/$imrole.$rec.sm.jpg`;
`rm $bsdir/orig/$imrole.$rec.tmp.jpg`;
} ## END VIDEO
elsif($mime =~ m/image/i) {my $ffrom="$imrole.$rec.$ext";
if($ext =~ m/png|gif/i) {`convert $bsdir/orig/$imrole.$rec.$ext -fill grey -opaque none $bsdir/orig/$imrole.$rec.tmp.$ext`;$ffrom="$imrole.$rec.tmp.$ext";}
`convert -density 72 $bsdir/orig/$ffrom -quality 50 -flatten -colorspace RGB +repage $webdir/logo/$imrole.$rec.jpg`;
`convert -density 72 $bsdir/orig/$ffrom -resize 120x -quality 50 -flatten -colorspace RGB +repage $webdir/logo/$imrole.$rec.sm.jpg`;
if($ffrom =~ m/\.tmp\./) {unlink "$bsdir/orig/$imrole.$rec.tmp.$ext";}
} ## END IMAGE
else {`rm $bsdir/orig/$imrole.$rec.$ext`;$dodelete=1;} ## END UNKNOWN TYPE
print TXR "----------------\n";
} ## END MAIN CONTENT

if($imrole =~ m/logo/) {
`mv "$f" $webdir/logo/$imrole.$rec.$ext`;
my $image = `anytopnm $webdir/logo/$imrole.$rec.$ext`;my($w,$h) = pnmsize($image);$image='';
unless($ext =~ m/png/i) {`convert $webdir/logo/$imrole.$rec.$ext -fuzz 20% -transparent white $bsdir/logoimage/$imrole.$rec.png`;}
else {`cp $webdir/logo/$imrole.$rec.$ext $bsdir/logoimage/$imrole.$rec.png`;}
if(-f "$bsdir/logoimage/$imrole.$rec.png") {
`rm $webdir/logo/$imrole.$rec.$ext`;
print TXR "file\t$bsdir/logoimage/$imrole.$rec.png\n----------------\n";
`convert $bsdir/logoimage/$imrole.$rec.png -fill grey -opaque none $webdir/logo/$imrole.$rec.a.jpg`;
`convert $webdir/logo/$imrole.$rec.a.jpg -resize 120x -quality 50 -flatten -colorspace RGB +repage $webdir/logo/$imrole.$rec.jpg`;
`rm $webdir/logo/$imrole.$rec.a.jpg`;
}
open(TXT,">$bsdir/logo/$imrole.$rec.txt");print TXT "$bsdir/logoimage/$imrole.$rec.png\t$w $h";close(TXT);
} ## END LOGO
} ## END EXTENSION PRESENT
else {print TXR "----------------\n";}
close(TXR);
if($dodelete) {`rm $bsdir/records/$rec.txt`;}
} ## END SUB GET EXIF

sub pnmsize {
my($pnm) = @_;
my ($width,$height);
($width,$height)=$pnm=~m#^P\d+\s+(\d+)\s+(\d+)\s+\d+\s#ois;
return ($width,$height) if ($width && $height);
} ## END SUB PNM SIZE ##

sub deletevideo { ######mainimage.1578448326
my $delfile=shift;my $mess='';
if($delfile =~ m/zip/) {$mess=&deletezip($delfile);return $mess;}
my $towrite='';my @rddta='';my %dtvd=();
$delfile =~ s#(.*?)/##g;$in{'img2'}=$delfile;
my $delimg=$delfile;$delimg =~ s#^(.*?)\.##;
$delfile =~ s/\.\w{3}$//;
if(-f "$webdir/logo/$delfile.jpg") {`rm $webdir/logo/$delfile.jpg`;$towrite=1;}
if(-f "$webdir/logo/$delfile.sm.jpg") {`rm $webdir/logo/$delfile.sm.jpg`;$towrite=1;}
if(-f "$bsdir/records/$delimg.txt") {my $fnd = `cat $bsdir/records/$delimg.txt`;@rddta = split(/\n/,$fnd);$fnd='';
foreach my $l (@rddta) {my($key,$val) = split(/\t/,$l);if($key && $val) {$dtvd{$key}=$val;}} # FOREACH
if(-f $dtvd{file}) {my @ffz = split(/\//,$dtvd{file});my $mvfn = pop(@ffz);`rm -f $dtvd{file}`;}
`rm -f $bsdir/records/$delimg.txt`;$towrite=1;}
if($towrite) {$mess='Video/Image source file is deleted - data updated in a few seconds';}
else {$mess='Nothing was deleted';}
#print "Content-type: text/html\n\n$mess";exit(0);
return($mess);
} ## END DELETE VIDEO ##

sub deletezip { ######
my $delfile=shift;$delfile =~ s/^zip\.//;my $mess='';my %recz=();
if(-f "$bsdir/tempzip/$remote_user/$delfile.txt") {my $d = `cat $bsdir/tempzip/$remote_user/$delfile.txt`;my @all = split(/\n/,$d);$d='';
foreach my $l (@all) {
my($fn,$key,$dta) = split(/\t/,$l);if($fn) {last;}
$recz{$key}=$dta;
} ## FOREACH LINE END
if(-d $recz{'IMG Dir'}) {`rm -rf $recz{'IMG Dir'}`;}
if(-f $recz{'ZIP file'}) {`rm $recz{'ZIP file'}`;}
`rm $bsdir/tempzip/$remote_user/$delfile.txt`;
if(-f "$webdir/logo/zipimage.$delfile.jpg") {`rm $webdir/logo/zipimage.$delfile.jpg`;}
$mess = "ZIP file and its content was deleted";return $mess;
} ## END IF CONTROL FILE PRESENT
else {$mess = "ZIP file was not found to delete";return $mess;}
} ## END DELETE ZIP ##

sub deletelogo {
my $delfile=shift;my $towrite='';my $mess='';
$delfile =~ s#(.*?)/##g;
my $delimg=$delfile;$delimg =~ s#^(.*?)\.##;$delimg =~ s/\.\w{3,4}$//;
if(-f "$bsdir/logoimage/$delfile") {`rm $bsdir/logoimage/$delfile`;$towrite=1;}
$delfile =~ s/\.\w{3}$//;
if(-f "$webdir/logo/$delfile.jpg") {`rm $webdir/logo/$delfile.jpg`;$towrite=1;}
if(-f "$webdir/logo/$delfile.png") {`rm $webdir/logo/$delfile.png`;$towrite=1;}
if(-f "$bsdir/logo/$delfile.txt") {`rm $bsdir/logo/$delfile.txt`;$towrite=1;}
if(-f "$bsdir/records/$delimg.txt") {`rm $bsdir/records/$delimg.txt`;$towrite=1;}
if($towrite) {$mess='Logo file is deleted';}
else {$mess='Nothing was deleted';}
return($mess);
} ## END DELETE LOGO

sub readdata {
my $f = shift;$f =~ s#$bsdir/records/(.*?)\.(.*)#$bsdir/records/$2#;
if(-f $f) {my $d = `cat $f`;my @alines = split(/\n/,$d);$d='';my %hd=();
foreach my $l (@alines) {
unless($l) {next;}
my($key,$val) = split(/\t/,$l);
if($key && $val) {$hd{$key}=$val;}
} ## FOREACH END
return %hd;
} ## END FILE PRESENT
} ## END READ DATA

sub writeremove {
my $list = shift;
open(TXR,">>$bsdir/removethemlater.txt");print TXR $list;close(TXR);
} ## END WRITE REMOVE LATER

sub num {$a <=> $b;}

sub getCookies {
my(@rawCookies) = split (/; /,$ENV{'HTTP_COOKIE'});
my(%cookies);

foreach(@rawCookies){
my($key, $val) = split (/=/,$_);
$cookies{$key} = $val;
}

return %cookies;
} ## END GET COOKIES

sub set_exp {
my $thisday = shift;
my $finaltime = localtime($thisday);$finaltime =~ tr/ //s;
my($wdT,$moT,$daT,$tiT,$yeT) = split(/\s/,$finaltime);
$daT = "0".$daT if (length($daT) < 2);
my($h_rT,$m_iT,$s_kT) = split(/\:/,$tiT);
$h_rT= "0".$h_rT if (length($h_rT) < 2);
$m_iT= "0".$m_iT if (length($m_iT) < 2);
$s_kT= "0".$s_kT if (length($s_kT) < 2);
$tiT = "$h_rT\:$m_iT\:$s_kT";
my $expDate = "$wdT, $daT-$moT-$yeT $tiT GMT";
return $expDate;
} ## END SUB SET EXP DATE

sub generate_randqr_string {
my $length_of_randomstring=shift;
my @chars=('a'..'z','0'..'9');
my $random_string;
foreach (1..$length_of_randomstring) {$random_string.=$chars[rand @chars];}
return $random_string;
} ## END SUB GENERATE RANDOM STR

sub setCookie {
my($name, $value, $expiration, $path, $domain, $secure) = @_;
print "Set-Cookie: ";
print ($name, "=", $value, "; expires=", $expiration, "; path=", $path, "; domain=", $domain, "; ", $secure, "\n");
} ## END SUB SET COOKIES

sub parse_duration {
my $seconds = shift;
my $hours = int( $seconds / (60*60) );
my $mins = ( $seconds / 60 ) % 60;
my $secs = $seconds % 60;
return sprintf("%02d Hr %02d Min %02d Sec", $hours,$mins,$secs);
}

sub createqr {
unless($in{qrtext}) {$mess = "\n<p style=\"color:#d00000;\">No QR text submitted</p>";return;}
$in{qrtext} =~ s/^\s+//;$in{qrtext} =~ s/\s+$//;$in{qrtext} =~ tr/ //s;$in{qrtext} =~ s/\"//g;
$in{qrmargin} =~ s/\D//g;if($in{qrmargin} > 5) {$in{qrmargin}=5;}
unless($in{qrmargin}) {$in{qrmargin}=3;}my $fnqr = time;
writeremove("$webdir/src/$fnqr.png\n");
`/usr/local/bin/qrencode -s 4 -l M -m $in{qrmargin} -d 300 -v 1 -o $webdir/src/$fnqr.png "$in{qrtext}"`; ## CREATES QR IMAGE 300 DPI
$mess = "\n<p><img src=\"src/$fnqr.png\" class=\"qrcode\" title=\"$in{qrtext}\"><br />\nTo download image above, please right-click and choose \"Save Image As\" or similar.</p>
<hr size=\"1\" width=\"35%\" align=\"left\">";
} ## END CREATE QR CODE SUB

sub verifyfilename {
my $filenm = shift;my $noit=0;my $filechange=$filenm;$filechange =~ s/\.(\w{2,4})$//;my $fext=$1;
while(1) {
if(-f $filenm) {$noit++;$filenm = "$filechange.$noit.$fext";}
else {last;}
} ## WHILE END
my @kspl = split(/\//,$filenm);$filenm = pop(@kspl);
return $filenm;
} ## END SUB VERIFY FILE NAME

sub unzipfiles { ##########
my $file = shift;my $exifdata = `exiftool $file | grep 'Type'`;
if(-f $file && $exifdata =~ m/\bzip\b/i) {my $zrec=time;
`mkdir -p $bsdir/tempzip/$remote_user/$zrec`;`chown $user\:$group $bsdir/tempzip/$remote_user/$zrec`;
`unzip $file -d $bsdir/tempzip/$remote_user/$zrec`;
return "$bsdir/tempzip/$remote_user/$zrec";
} ## END ZIP FILE PRESENT
else {return;}
} ## END SUB UNZIP FILES ##

sub createzipfile {
my $rec=shift;
if(-f "$bsdir/tempzip/$remote_user/$rec.txt") { ## SOURCE FILE PRESENT
my($lftype,$lfile,$lwidth,$lheight,$lfps,$lvdur,$ibitrate)=getcmbdata($in{'logo'});
my $writing=time;my $fremove='';
$in{width} =~ s/\D//g;$in{height} =~ s/\D//g;
if($in{width} == $lwidth) {$in{width}='';}
if($in{height} == $lheight) {$in{height}='';}
if($in{width} || $in{height}) {my $sspr='x';
`convert $lfile -resize $in{width}$sspr$in{height} $bsdir/temp/$writing.png`;$lfile="$bsdir/temp/$writing.png";$fremove="rm $lfile\n";
} ## END WIDTH OR HEIGHT PRESENT
$in{arotate} =~ s/\D//g;my $actrotate=0;
if($in{rotate} > 360) {$in{rotate} = 1;}
if($in{arotate} > 360 || $in{arotate} < 1) {$in{arotate} = '';}
if($in{arotate}) {$actrotate=$in{arotate};$in{rotate}=0;}
else {
if($in{rotate} > 1) {$actrotate=$in{rotate};}
} ## END NOT ARBITRARY ROTATE PRESENT
if($actrotate) {
`convert -background none -rotate $actrotate $lfile $bsdir/temp/$writing.r.png`;$lfile="$bsdir/temp/$writing.r.png";$fremove.="rm $lfile\n";
} ## END IF ROTATE
unless($in{opacity}) {$in{opacity}=30;}
unless($in{xoffset}) {$in{xoffset}=20;}
unless($in{yoffset}) {$in{yoffset}=20;}

my $d = `cat $bsdir/tempzip/$remote_user/$rec.txt`;my @ifiles=split(/\n/,$d);$d='';
my %timgdata=();
foreach my $l (@ifiles) {
my($im,$key,$val) = split(/\t/,$l);unless($im && $key && $val) {next;}$timgdata{$im}{$key}=$val;
} ## FOREACH END
my $codewrite="process\tmkdir -p $bsdir/zip/$remote_user\n";
foreach my $im (sort keys(%timgdata)) { #### <<<
$codewrite .= "process\tcomposite -dissolve $in{opacity}% -gravity $gravity{$in{placement}} -geometry +$in{xoffset}+$in{yoffset} $lfile $bsdir/tempzip/$remote_user/$rec/$im $bsdir/zip/$remote_user/$im\n";
} ## FOREACH IM END ######################## <<<
$codewrite .= "process\tzip -j $webdir/src/$writing.zip -r $bsdir/zip/$remote_user\nprocess\trm -rf $bsdir/zip/$remote_user\n";
$codewrite .= "write\t$writing link $webhtm/src/$writing.zip\nwrite\t$writing img $webhtm/zip.png\n";
if($fremove) {$codewrite .= "process\t$fremove";}

my $program='/usr/bin/perl $webdir/bkg.cgi';my $foundit = 0;
open (IN, "ps axw |");while (<IN>) {
if(/$program/) {$foundit = 1;last;}
}close IN; ## WHILE END
if($foundit) {my $title='Program already running';
my $htmlpg = "<p>Server is currently processing video or ZIP file. Only one process allowed at the time. Please re-load this page when program finishes.</p>
<p>Thank you!</p>";preprintpage($title,$htmlpg);exit(0);} ## END PROGRAM IS RUNNING ALREADY
my $rprocess = generate_randqr_string(14);open(TXD,">$bsdir/process.$rprocess.txt");print TXD $codewrite;close(TXD);
my $pid = fork;
if($pid == 0) { ##
open STDIN, "</dev/null";open STDOUT, ">/dev/null";open STDERR, ">/dev/null";
`/usr/bin/perl $webdir/bkg.cgi $rprocess $remote_user`;exit(0);
} ## FORK THE PROCESS IF PID ###

my $title='We\'re processing your request';
my $htmlpg = "<p>Your ZIP file with all images will be processed shortly by the server.<br />
Once program finishes processing you will be notified by e-mail, or you can go to:<br />
<a href=\"$webhtm/d/\">Download page</a></p>
<p>Thank you!</p>";
my $rmltr = "$webdir/src/$writing.zip\n";writeremove($rmltr);
preprintpage($title,$htmlpg);
} ## END SOURCE FILE PRESENT
else {$mess = "\n<p style=\"color:#d00000;\">Unable to create images - source file missing</p>";return;}
} ## END CREATE ZIP FILE

sub createdirs { ########
my $created='';
unless(-d "$webdir/d") {`mkdir -p $webdir/d`;$created = "$webdir/d\n";}
unless(-d "$webdir/logo") {`mkdir -p $webdir/logo`;$created = "$webdir/logo\n";}
unless(-d "$webdir/src") {`mkdir -p $webdir/src`;$created = "$webdir/src\n";}
unless(-d "$bsdir/logo") {`mkdir -p $bsdir/logo`;$created = "$bsdir/logo\n";}
unless(-d "$bsdir/logoimage") {`mkdir -p $bsdir/logoimage`;$created = "$bsdir/logoimage\n";}
unless(-d "$bsdir/orig") {`mkdir -p $bsdir/orig`;$created = "$bsdir/orig\n";}
unless(-d "$bsdir/records") {`mkdir -p $bsdir/records`;$created = "$bsdir/records\n";}
unless(-d "$bsdir/temp") {`mkdir -p $bsdir/temp`;$created = "$bsdir/temp\n";}
unless(-d "$bsdir/temp1") {`mkdir -p $bsdir/temp1`;$created = "$bsdir/temp1\n";}
unless(-d "$bsdir/tempzip") {`mkdir -p $bsdir/tempzip`;$created = "$bsdir/tempzip\n";}
unless(-d $coocdir) {`mkdir -p $coocdir`;$created = "$coocdir\n";}
unless(-d "$bsdir/zip") {`mkdir -p $bsdir/zip`;$created = "$bsdir/zip\n";}
if($created) {chomp $created;$created =~ s#\n#</li>\n<li>#g;
$created = "\n<p style=\"color:#d00000\">The followind folders were created:<ul>\n<li>$created</li>\n</ul>\n<p>";}
else {$created = "\n<p style=\"color:#00d000\">All folders are present - nothing was created</p>";}
return $created;
} ## END CREATE DIRS ####

sub cleandirs {
if(-f "$bsdir/removethemlater.txt") {my $d = `cat $bsdir/removethemlater.txt`;my @allf = split(/\n/,$d);$d='';
`rm $bsdir/removethemlater.txt`;my %ffl=();my $tonew='';my $nowtme=time;
foreach my $f (@allf) {$ffl{$f}=1;} ## FOREACH FILE END
foreach my $f (keys (%ffl)) {
if(-f $f) {
my $fvozr = (stat ($f))[10];
my $flpSt = $nowtme - $fvozr;
if($flpSt > 86400) {`rm -f $f`;} else {$tonew .= "$f\n";}
} ## END FILE PRESENT
} ## FOREACH 2 END
if($tonew) {open(TNN,">$bsdir/removethemlater.txt");print TNN $tonew;close(TNN);}
} ## END DELETE FILES FILE PRESENT
} ## END CLEAN

View Code#!/usr/bin/perl
## Copyright 2020 CodeMacs.Com
## FREE open-source program to create overlay logo on video and image files
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute,
# copies of the Software, and to permit persons to whom the Software
# is furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
# OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

use strict;
$| = 1;
my $webdir='/home/account/www/improcess';## WEB FOLDER
my $webhtm='/improcess';## HTML WEB FOLDER
my $bsdir='/home/account/improcess';## NOT ACCESSIBLE FROM THE WEB FOLDER
my $thisday = time;my $finaltime = localtime($thisday);
open(TXT,">$webdir/src/last.run.cgi");print TXT "Started at: $finaltime\n";
my $process = $ARGV[0];$process =~ s/\r|\n//g;
my $usersweb = $ARGV[1];$usersweb =~ s/\n|\r//g;
if(-f "$bsdir/process.$process.txt") {
print TXT "File process.$process.txt exist\n";
my $d = `cat $bsdir/process.$process.txt`;print TXT "$d\n-----------------\n\n";
my @lns = split(/\n/,$d);$d='';my $dtwrite='';
foreach my $l (@lns) {
unless($l) {next;}
my($task,$code) = split(/\t/,$l);my $created=time;
if($task eq 'process') {print TXT "Processing: $code\n";`$code`;}
elsif($task eq 'write') {$dtwrite .= "$code $created\n";}
else {print TXT "No process: $l\n";}
} ## FOREACH LINE END
open(DNL,">>$bsdir/download.$usersweb.txt");print DNL $dtwrite;close(DNL);print TXT "writing downloads file\n";
print TXT "\tsending email to $usersweb\n";sendemail($usersweb);
} ## END PROCESS FILE PRESENT
my $endtime = time;$finaltime = localtime($endtime);
my $lapsed = $endtime - $thisday;
print TXT "Ended: $finaltime\nRan for $lapsed seconds\n";
close(TXT);

exit(0);

sub sendemail {
my $user = shift;
unless(-f "$bsdir/temp/emailed.to.$user") {`touch $bsdir/temp/emailed.to.$user`;
if(-f "$bsdir/users.txt") {
my $d = `cat $bsdir/users.txt | grep "$user"`;$d =~ s#\n|\r##g;
my($userw,$name,$email,$grp) = split(/\t/,$d);
print TXT "grep: $d\nUser data:\n$d\n";
my $sendmail = '/usr/sbin/sendmail -t -oi';
open(MAIL,"|$sendmail");
print MAIL <<EOM;
From: info\@your_domain.com\nTo: $email ($name)\nSubject: File(s) ready for download\n
$name,
Files processing is finished. Please point your browser to the download page:
www.your_site.com$webhtm/d/
This email sent only once a day. If you processing more files Today, please use link above to download them.
EOM
close(MAIL);
} ## END FILE PRESENT
else {print TXT "No users file $user found\n";}
} ## END UNLESS EMAILED TODAY
else {print TXT "Already sent email to $user today\n";}
} ## END SEND EMAIL

View Code#!/usr/bin/perl
## Copyright 2020 CodeMacs.Com
## FREE open-source program to create overlay logo on video and image files
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute,
# copies of the Software, and to permit persons to whom the Software
# is furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
# OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
use strict;
my $hostname = `/bin/hostname`;chomp $hostname;
my $remote_user = $ENV{REMOTE_USER};
unless($remote_user) {$remote_user = 'none';}

my $webdir='/home/account/www/improcess';## WEB FOLDER
my $webhtm='/improcess';## HTML WEB FOLDER
my $bsdir='/home/account/improcess';## NOT ACCESSIBLE FROM THE WEB FOLDER
my $coocdir='/home/account/cookies';## COOKIES FOLDER

my %images=();my $title='';my $htmlpg='';
if(-f "$bsdir/download.$remote_user.txt") {my $d = `cat $bsdir/download.$remote_user.txt`;my @lnz = split(/\n/,$d);$d='';
foreach my $l (@lnz) {
my($key,$which,$file,$crted) = split(/ /,$l);$images{$key}{$which}=$file;$images{$key}{created}=$crted;
} ## FOREACH END
} ## END DATA PRESENT
else {
$title = 'No files ready yet';
$htmlpg = "<p>Please give some more time for program to finish processing your file(s).</p>\n<p>Thank you!</p>";
preprintpage($title,$htmlpg);
} ## END NO DATA

my $imglist='';my $tmnow=time;my $rmlnz='';my $towrite='';
foreach my $t (sort num keys(%images)) {my $imw='';
if(-f "$webdir$images{$t}{link}" && -f "$webdir$images{$t}{img}") {
my $lapsed = $tmnow - $images{$t}{created};my $buildago=&parse_duration($lapsed);
unless($images{$t}{img} =~ m/zip/i) {$imw=" width=\"120\"";}
$imglist .= "<li><a href=\"$images{$t}{link}\"><img src=\"$images{$t}{img}\"$imw></a> <span>file built $buildago ago</span></li>\n";
$towrite .= "$t link $images{$t}{link} $images{$t}{created}\n$t img $images{$t}{img} $images{$t}{created}\n";
} ## END FILE PRESENT
else {$rmlnz=1;}
} ## FOREACH IMG KEY END

if($rmlnz) {
if($towrite) {open(WRT,">$bsdir/download.$remote_user.txt");print WRT $towrite;close(WRT);}
else {
if(-f "$bsdir/download.$remote_user.txt") {`rm $bsdir/download.$remote_user.txt`;}
}
} ## END IF REMOVE

unless($towrite) {$title='Files expired';
my $htmlpg = "<p>No processed files found. Please go back and try submitting files for processing.</p>
<p>Thank you!</p>";preprintpage($title,$htmlpg);
} ## END FILES PRESENT

$title='Processed files';
my $htmlpg = "<p>Please right-click on the appropriate image and select from the drop-down menu \"Save Target As\" or similar option to download processed file.<br />
Files kept for 24 hours after processing.</p>
<p><ul class=\"imglist\">\n$imglist</ul></p>";

preprintpage($title,$htmlpg);

sub preprintpage {
my($title,$html) = @_;
print "Content-type: text/html\n\n";
print <<EOH;
<html>
<head>
<title>$title</title>
<meta name="viewport" content="width=device-width, initial-scale=1">
<link rel="stylesheet" type="text/css" href="$webhtm/all.css" media="screen"/>
<style>input[type=text]{width:auto;}</style>
</head>
<body>
<h1>$title</h1>
$html
<hr size="1" width="30%" align="left">
<p><a href=\"$webhtm/\">Back to Main Page</a></p>
</body>\n</html>
EOH
exit(0);
} ## END PRE PRINT PAGE

sub num {$b <=> $a;}

sub parse_duration {
my $seconds = shift;
my $hours = int( $seconds / (60*60) );
my $mins = ( $seconds / 60 ) % 60;
my $secs = $seconds % 60;
return sprintf("%02d Hr %02d Min %02d Sec", $hours,$mins,$secs);
}

View Code# Perl Routines to Manipulate CGI input
# [email protected]
# $Id: cgi-lib.pl,v 2.17 1998/05/14 22:39:23 brenner Exp $
#
# Copyright (c) 1993-1998 Steven E. Brenner
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
#
# Thanks are due to many people for reporting bugs and suggestions

# For more information, see:
# http://cgi-lib.stanford.edu/cgi-lib/

$cgi_lib'version = sprintf("%d.%02d", q$Revision: 2.17 $ =~ /(\d+)\.(\d+)/);

# Parameters affecting cgi-lib behavior
# User-configurable parameters affecting file upload.
$cgi_lib'maxdata = 2147483648; # maximum bytes to accept via POST - 2^17
$cgi_lib'writefiles = '/temp';# directory to which to write files, or
$cgi_lib'writefiles = 0; # directory to which to write files, or
# 0 if files should not be written
$cgi_lib'filepre = "cgi-lib"; # Prefix of file names, in directory above

# Do not change the following parameters unless you have special reasons
$cgi_lib'bufsize = 8192; # default buffer size when reading multipart
$cgi_lib'maxbound = 100; # maximum boundary length to be encounterd
$cgi_lib'headerout = 0; # indicates whether the header has been printed

# ReadParse
# Reads in GET or POST data, converts it to unescaped text, and puts
# key/value pairs in %in, using "\0" to separate multiple selections

# Returns >0 if there was input, 0 if there was no input
# undef indicates some failure.

# Now that cgi scripts can be put in the normal file space, it is useful
# to combine both the form and the script in one place. If no parameters
# are given (i.e., ReadParse returns FALSE), then a form could be output.

# If a reference to a hash is given, then the data will be stored in that
# hash, but the data from $in and @in will become inaccessable.
# If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse,
# information is stored there, rather than in $in, @in, and %in.
# Second, third, and fourth parameters fill associative arrays analagous to
# %in with data relevant to file uploads.

# If no method is given, the script will process both command-line arguments
# of the form: name=value and any text that is in $ENV{'QUERY_STRING'}
# This is intended to aid debugging and may be changed in future releases

sub ReadParse {
local (*in) = shift if @_; # CGI input
local (*incfn, # Client's filename (may not be provided)
*inct, # Client's content-type (may not be provided)
*insfn) = @_; # Server's filename (for spooled files)
local ($len, $type, $meth, $errflag, $cmdflag, $perlwarn, $got, $name);

# Disable warnings as this code deliberately uses local and environment
# variables which are preset to undef (i.e., not explicitly initialized)
$perlwarn = $^W;
$^W = 0;

binmode(STDIN); # we need these for DOS-based systems
binmode(STDOUT); # and they shouldn't hurt anything else
binmode(STDERR);

# Get several useful env variables
$type = $ENV{'CONTENT_TYPE'};
$len = $ENV{'CONTENT_LENGTH'};
$meth = $ENV{'REQUEST_METHOD'};

if ($len > $cgi_lib'maxdata) { #'
&CgiDie("Upload: Too much data sent to the form: $len bytes\nPlease select fewer images to upload at one time.");
}

if (!defined $meth || $meth eq '' || $meth eq 'GET' ||
$meth eq 'HEAD' ||
$type eq 'application/x-www-form-urlencoded') {
local ($key, $val, $i);

# Read in text
if (!defined $meth || $meth eq '') {
$in = $ENV{'QUERY_STRING'};
$cmdflag = 1; # also use command-line options
} elsif($meth eq 'GET' || $meth eq 'HEAD') {
$in = $ENV{'QUERY_STRING'};
} elsif ($meth eq 'POST') {
if (($got = read(STDIN, $in, $len) != $len))
{$errflag="Short Read: wanted $len, got $got\n";};
} else {
&CgiDie("cgi-lib.pl: Unknown request method: $meth\n");
}

@in = split(/[&;]/,$in);
push(@in, @ARGV) if $cmdflag; # add command-line parameters

foreach $i (0 .. $#in) {
# Convert plus to space
$in[$i] =~ s/\+/ /g;

# Split into key and value.
($key, $val) = split(/=/,$in[$i],2); # splits on the first =.

# Convert %XX from hex numbers to alphanumeric
$key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
$val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;

# Associate key and value
$in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
$in{$key} .= $val;
}

} elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) {
# for efficiency, compile multipart code only if needed
$errflag = !(eval <<'END_MULTIPART');

local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen);
local ($bpos, $lpos, $left, $amt, $fn, $ser);
local ($bufsize, $maxbound, $writefiles) =
($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles);

# The following lines exist solely to eliminate spurious warning messages
$buf = '';

($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary
($boundary) = $type =~ /boundary=(\S+)/ unless $boundary;
&CgiDie ("Boundary not provided: probably a bug in your server")
unless $boundary;
$boundary = "--" . $boundary;
$blen = length ($boundary);

if ($ENV{'REQUEST_METHOD'} ne 'POST') {
&CgiDie("Invalid request method for multipart/form-data: $meth\n");
}

if ($writefiles) {
local($me);
stat ($writefiles);
$writefiles = "/tmp" unless -d _ && -w _;
# ($me) = $0 =~ m#([^/]*)$#;
$writefiles .= "/$cgi_lib'filepre";
}

# read in the data and split into parts:
# put headers in @in and data in %in
# General algorithm:
# There are two dividers: the border and the '\r\n\r\n' between
# header and body. Iterate between searching for these
# Retain a buffer of size(bufsize+maxbound); the latter part is
# to ensure that dividers don't get lost by wrapping between two bufs
# Look for a divider in the current batch. If not found, then
# save all of bufsize, move the maxbound extra buffer to the front of
# the buffer, and read in a new bufsize bytes. If a divider is found,
# save everything up to the divider. Then empty the buffer of everything
# up to the end of the divider. Refill buffer to bufsize+maxbound
# Note slightly odd organization. Code before BODY: really goes with
# code following HEAD:, but is put first to 'pre-fill' buffers. BODY:
# is placed before HEAD: because we first need to discard any 'preface,'
# which would be analagous to a body without a preceeding head.

$left = $len;
PART: # find each part of the multi-part while reading data
while (1) {
die $@ if $errflag;

$amt = ($left > $bufsize+$maxbound-length($buf)
? $bufsize+$maxbound-length($buf): $left);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;

$in{$name} .= "\0" if defined $in{$name};
$in{$name} .= $fn if $fn;

$name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted
if (defined $1) {
$insfn{$1} .= "\0" if defined $insfn{$1};
$insfn{$1} .= $fn if $fn;
}

BODY:
while (($bpos = index($buf, $boundary)) == -1) {
if ($left == 0 && $buf eq '') {
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie("cgi-lib.pl: reached end of input while seeking boundary " .
"of multipart. Format of CGI input is wrong.\n");
}
die $@ if $errflag;
if ($name) { # if no $name, then it's the prologue -- discard
if ($fn) { print FILE substr($buf, 0, $bufsize); }
else { $in{$name} .= substr($buf, 0, $bufsize); }
}
$buf = substr($buf, $bufsize);
$amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
}
if (defined $name) { # if no $name, then it's the prologue -- discard
if ($fn) { print FILE substr($buf, 0, $bpos-2); }
else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n
}
close (FILE);
last PART if substr($buf, $bpos + $blen, 2) eq "--";
substr($buf, 0, $bpos+$blen+2) = '';
$amt = ($left > $bufsize+$maxbound-length($buf)
? $bufsize+$maxbound-length($buf) : $left);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;

undef $head; undef $fn;
HEAD:
while (($lpos = index($buf, "\r\n\r\n")) == -1) {
if ($left == 0 && $buf eq '') {
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie("cgi-lib: reached end of input while seeking end of " .
"headers. Format of CGI input is wrong.\n$buf");
}
die $@ if $errflag;
$head .= substr($buf, 0, $bufsize);
$buf = substr($buf, $bufsize);
$amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
}
$head .= substr($buf, 0, $lpos+2);
push (@in, $head);
@heads = split("\r\n", $head);
($cd) = grep (/^\s*Content-Disposition:/i, @heads);
($ct) = grep (/^\s*Content-Type:/i, @heads);

($name) = $cd =~ /\bname="([^"]+)"/i; #";
($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;

($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str
($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname;
$incfn{$name} .= (defined $in{$name} ? "\0" : "") .
(defined $fname ? $fname : "");

($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #";
($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype;
$inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype;

if ($writefiles && defined $fname) {
$ser++;
$fn = $writefiles . ".$$.$ser";
open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n");
binmode (FILE); # write files accurately
}
substr($buf, 0, $lpos+4) = '';
undef $fname;
undef $ctype;
}

1;
END_MULTIPART
if ($errflag) {
local ($errmsg, $value);
$errmsg = $@ || $errflag;
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie($errmsg);
} else {
# everything's ok.
}
} else {
&CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n");
}

# no-ops to avoid warnings
$insfn = $insfn;
$incfn = $incfn;
$inct = $inct;

$^W = $perlwarn;

return ($errflag ? undef : scalar(@in));
}

# PrintHeader
# Returns the magic line which tells WWW that we're an HTML document

sub PrintHeader {
return "Content-type: text/html\n\n";
}

# HtmlTop
# Returns the <head> of a document and the beginning of the body
# with the title and a body <h1> header as specified by the parameter

sub HtmlTop
{
local ($title) = @_;

return <<END_OF_TEXT;
<html>
<head>
<title>$title</title>
</head>
<body>
<h1>$title</h1>
END_OF_TEXT
}

# HtmlBot
# Returns the </body>, </html> codes for the bottom of every HTML page

sub HtmlBot
{
return "</body>\n</html>\n";
}

# SplitParam
# Splits a multi-valued parameter into a list of the constituent parameters

sub SplitParam
{
local ($param) = @_;
local (@params) = split ("\0", $param);
return (wantarray ? @params : $params[0]);
}

# MethGet
# Return true if this cgi call was using the GET request, false otherwise

sub MethGet {
return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET");
}

# MethPost
# Return true if this cgi call was using the POST request, false otherwise

sub MethPost {
return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST");
}

# MyBaseUrl
# Returns the base URL to the script (i.e., no extra path or query string)
sub MyBaseUrl {
local ($ret, $perlwarn);
$perlwarn = $^W; $^W = 0;
$ret = ''.$ENV{'SERVER_NAME'}.
($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
$ENV{'SCRIPT_NAME'};
$^W = $perlwarn;
return $ret;
}

# MyFullUrl
# Returns the full URL to the script (i.e., with extra path or query string)
sub MyFullUrl {
local ($ret, $perlwarn);
$perlwarn = $^W; $^W = 0;
$ret = 'http://'.$ENV{'SERVER_NAME'}.
($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
$ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} .
(length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : '');
$^W = $perlwarn;
return $ret;
}

# MyURL
# Returns the base URL to the script (i.e., no extra path or query string)
# This is obsolete and will be removed in later versions
sub MyURL {
return &MyBaseUrl;
}

# CgiError
# Prints out an error message which which containes appropriate headers,
# markup, etcetera.
# Parameters:
# If no parameters, gives a generic error message
# Otherwise, the first parameter will be the title and the rest will
# be given as different paragraphs of the body

sub CgiError {
local (@msg) = @_;
local ($i,$name);

if (!@msg) {
$name = &MyFullUrl;
@msg = ("Error: script $name encountered fatal error\n");
};

if (!$cgi_lib'headerout) { #')
print &PrintHeader;
print "<html>\n<head>\n<title>$msg[0]</title>\n</head>\n<body>\n";
}
print "<h1>$msg[0]</h1>\n";
foreach $i (1 .. $#msg) {
print "<p>$msg[$i]</p>\n";
}

$cgi_lib'headerout++;
}

# CgiDie
# Identical to CgiError, but also quits with the passed error message.

sub CgiDie {
local (@msg) = @_;
&CgiError (@msg);
die @msg;
}

# PrintVariables
# Nicely formats variables. Three calling options:
# A non-null associative array - prints the items in that array
# A type-glob - prints the items in the associated assoc array
# nothing - defaults to use %in
# Typical use: &PrintVariables()

sub PrintVariables {
local (*in) = @_ if @_ == 1;
local (%in) = @_ if @_ > 1;
local ($out, $key, $output);

$output = "\n<dl compact>\n";
foreach $key (sort keys(%in)) {
foreach (split("\0", $in{$key})) {
($out = $_) =~ s/\n/<br>\n/g;
$output .= "<dt><b>$key</b>\n <dd>:<i>$out</i>:<br>\n";
}
}
$output .= "</dl>\n";

return $output;
}

# PrintEnv
# Nicely formats all environment variables and returns HTML string
sub PrintEnv {
&PrintVariables(*ENV);
}

# The following lines exist only to avoid warning messages
$cgi_lib'writefiles = $cgi_lib'writefiles;
$cgi_lib'bufsize = $cgi_lib'bufsize ;
$cgi_lib'maxbound = $cgi_lib'maxbound;
$cgi_lib'version = $cgi_lib'version;
$cgi_lib'filepre = $cgi_lib'filepre;

1; #return true