#!/usr/bin/perl -T # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #NAME # tuneget # #SYNOPSIS #
# #REQUIRES $version = '20140316'; # Which version we claim to be $keywords = 'sheet,music,musician,musical,ABC,notation,instrument,lesson,manuscript'; require &LocalSetup(1); # Figure out localization stuff require "now.pm"; require "blacklist.pm"; # Code to recognize and block abusers $title = $P; # Title to use unless a better one is found. # use Scalar::Util; require "sendsubs.pm"; # Routines to send messages require "taintsubs.pm"; # Routines to untaint input values require "outtune.pm"; # Write a tune to a file require "formats.pm"; # File-format routines require "cfgload.pm"; # Host config-file routines # require "htmlenc.pm"; # HTML-encoding routines require "URLenc.pm"; # URL-encoding routines require "URLopen.pm" if $useURLopen; require "HTTPcon.pm"; require "timecmd.pm"; # Call subprocess with timeout require "unicode.pm"; # Unicode tools require "DT.pm"; # Date/Time routines # #DESCRIPTION # This is invoked by JC's Tune Finder to download ABC files, extract tunes, # and deliver them in various formats. # #BUGS # There is some badly damages ABC on the Net, and we don't do much to try to # recover from it. With time, some heuristics may be added to fix some of # the major problems, but this is a serious AI project and isn't likely to # happen soon. # #AUTHOR # Copyright 1999, 2001 by John Chambers # You may use this program as long as you don't try to sell it or claim that # it is yours. If you make any significant changes, take credit for them, # and please send me a copy. # # DESCRIPTION # # AUTHOR # John Chambers # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # $| = 1; $exitstat = 0; $F = ''; # Function name, if any. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Assorted global variables: $Fopt = ''; # Format-file, if any $RA = '?'; # was '0.0.0.0'; # The remote client's address, if known $UA = 'Unknown'; # The remote client's name or description $charset = 'UTF-8' # Make sure we have a defined charset unless defined $charset; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Some global settings that might need adjusting: $mimetype = "text/html"; # We now always produce text/html $embedtype = ''; # Type if we use an embedded object $extraDivs = 1; # Show "unnecessary"
tags (mostly to get borders) $maxcopies = 5; # Max copies of this program allowed at once $pslimit = 5; # Time limit for comversion to PS $showmatches = 1; # Whether to show matched tunes $useURLopen = 0; # Open URLs ourself via URLopen() $useCenter = 1; # Use the
tag $usew3cat = 0; # Start w3cat subprocess to open a URL $usewebcat = 1; # Start webcat subprocess to open a URL # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # These should be defined by now: $BBfmt = '??' unless defined $BBfmt; $CR = '??' unless defined $CR; $docdir = '??' unless defined $docdir; $fld = '??' unless defined $fld; $giffile = '??' unless defined $giffile; $keeplog = '??' unless defined $keeplog; $keeppdf = '??' unless defined $keeppdf; $keepps = '??' unless defined $keepps; $LF = '??' unless defined $LF; $Lopen = '??' unless defined $Lopen; $pdfurl = '' unless defined $pdfurl; $pngfile = '??' unless defined $pngfile; $svgfile = '??' unless defined $svgfile; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Global vars for the Uline() routine: $Ubuf = ''; $Upat = '^(.*?)($CR$LF|$LF$CR|$LF|$CR)(.*)$'; $Ulen = 200; $Utmp = ''; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Look for a few things in the environment: $RA = &tIPad($ENV{REMOTE_ADDR}); # Client's IP address $SV = $ENV{'HTTP_HOST'} || $ENV{SERVER_NAME} || 'localhost'; # What machine is this? $UA = $ENV{HTTP_USER_AGENT} || "unknown"; # What sort of client? $pathinfo = $ENV{"PATH_INFO"} || ''; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Set up the CGI package to handle our form parameters. use CGI; use CGI::Carp 'fatalsToBrowser'; use diagnostics; $cgi = new CGI; print "Content-type: text/html\n\n"; @Send = (); # List of debug stuff to send once we've sent the tag push @Send, ""; push @Send, ""; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # #if ($V>2) { # &dumpParams(); #} # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # This should give us the form data: our %data = $cgi->Vars; # Our data $URL = &tURL($data{U} || ''); # Is a URL requested? $B = &tInt($data{B}, $B || 1); # Is border width specified? # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Set up our logfile. $pid = $$; $logfile = "$tmpdir/Tune-$pid.log"; $altfile = "$tmpdir/lastGet.log"; if (!open(L,">>$logfile")) { &sendAll("### Can't write \"$logfile\" ($!) ###\n"); &done(1); } $Lopen = 1; # Logfile is now open select L; $| = 1; select STDOUT; unlink($altfile) if -f $altfile; link($logfile,$altfile); &sendLog("$ymd $hms PID=$$ V=$V \"$P\" version $version Vtest=$Vtest V=$V.\n") if $V>0; &sendLog("RA=\"$RA\" UA=\"$UA\"\n") if $V>0; &sendLog("cgiloc=\"$cgiloc\"\n") if $V>0; &sendLog("ENV{PATH}: \"$ENV{PATH}\"\n") if $V>0; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendLog("DATA:\n"); # if $V>0; $formvars = 0; for $key (sort keys %data) { $val = $data{$key}; &sendLog("\t$key: \"$val\"\n"); # if $V>0; ++$formvars; } #&sendLog("Is U in form data?\n"); #if ($Urq = &tWord($data{U},'')) { # &sendLog("Urq=\"$Urq\"\n") if $V>0; #} # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Did the client send us a verbose level? &sendLog("Is V in form data?\n"); if (defined($Varg = $data{V})) { &sendLog("data{V}='$Varg'='$data{V}'\n"); # if $V>0; if ($Varg =~ /^\s*(\d+)/) { $V = $fld{V} = int($1); $Vsrc = 'data{V}'; &sendLog("V=$V (from data)\n"); # if $V>0; } else { &sendLog("V='$Varg' ignored (not numeric).\n") if $V>0; } } else { &sendLog("V not defined in data.\n") if $V>1; } &sendLog("V=$V\n") if $V>1; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendLog("Is T in form data?\n"); if (defined($Targ = $data{T})) { &sendLog("title=\"$Targ\"\n") if $V>0; } else { &sendLog("T not defined in data.\n") if $V>1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Some global constants: $LF = \0x0A; # Line Feed char $CR = \0x0D; # Carriage Return char $a2p = 'jcabc2ps'; # Default ABC-to-PostScript program $scale ='0.65'; # Default scale factor $hres = '200'; # Default horizontal resolution $vres = '200'; # Default vertical resolution #G1fmt = 'G1'; # Android G1 C format file #G1hres = '120'; # Android G1 C horizontal resolution (was 63) #G1vres = '120'; # Android G1 C vertical resolution (was 63) #PTfmt = '_PT'; # Palm Tungsten C format file #PThres = '150'; # Palm Tungsten C horizontal resolution #PTvres = '120'; # Palm Tungsten C vertical resolution #BBfmt = '_BB'; # BlackBerry format file #BBhres = '114'; # BlackBerry horizontal resolution #BBvres = '120'; # BlackBerry vertical resolution $client = '?'; # Client type, if known $chkONeills = 1; # Enable O'Neill Project kludge/heuristic $gotONeills = 0; # Count of O'Neill Project tunes $ONeillsURL = '/~jc/music/book/oneills/'; #ONeillsStr = '/~jc/music/book/oneills/'; $nf = 'rel="nofollow"'; # Link attribute to discourage bots from following link $B = 0 unless defined $B || defined($B = $data{B}); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # We tailor some of our output for specific client types: $client = 'unknown-client'; $fmt = 'unknown-fmt'; if ($UA =~ /\bLynx\b/i) { # Lynx brower defaults to simple $client = 'Lynx'; $images = 0; #} elsif ($UA =~ /Android.*KHTML.*Mobile Safari/i) { # Android G1 # &sendLog("Identified Android KHTML Mobile Safari client.\n") if $V>0; # $client = $G1fmt; # $fmt = "_$G1fmt"; # $hres = $G1hres; # $vres = $G1vres; # $scale = $Sopt = '0.65'; # ($scl = $scale) =~ s/^0*\.//; # $sopt = '-s $scale'; # $fmt = "_$scl"; # $images = 1; # Images work here #} elsif ($UA =~ /PalmOS/i) { # PalmOS defaults to min # &sendLog("Identified PalmOS client.\n") if $V>0; # if ($UA =~ /Tungsten/i) { # Palm Tungsten # &sendLog("Identified Palm Tungsten client.\n") if $V>0; # $client = 'PT'; # $fmt = '_PT'; # abc2ps format file # $hres = $PThres; # $vres = $PTvres; # $images = 1; # Images work here # } elsif ($UA =~ /\bPalmOS\b/i) { # $client = 'Palm'; # PalmOS defaults to min # $images = 0; # Images don't work on most PalmOS gadgets # } #} elsif ($UA =~ /\b(Reqwireless|RIM)\b/i) { # BlackBerry # $client = 'RIM'; # $fmt = '_BB'; # mbc2ps format file # $hres = $BBhres; # $vres = $BBvres; # $images = 1; # This one does images } else { $client = 'Unknown'; $images = 1; } &sendLog("client='$client'\n") if $V>0; &sendLog("fmt='$fmt'\n") if $V>0; &sendLog("hres='$hres'\n") if $V>0; &sendLog("vres='$vres'\n") if $V>0; $client = '?' unless defined $client; $fmt = '?' unless defined $fmt; $hres = '?' unless defined $hres; $vres = '?' unless defined $vres; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Here's a list of filenames that we use: $abcfile = "$tmpdir/Tune-$pid.abc"; $txtfile = "$tmpdir/Tune-$pid.txt"; $psfile = "$tmpdir/Tune-$pid.ps"; $h5file = "$tmpdir/Tune-$pid.html"; $h5last = "$tmpdir/lastTune.html"; $epsfil0 = "$tmpdir/Tune-$pid.eps"; #epsfil1 = "$tmpdir/Tune-$pid" . '001.eps'; #epsfils = "$tmpdir/Tune-$pid" . '*.eps'; $giffile = "$tmpdir/Tune-$pid.gif"; $gifurl = "$tmpurl/Tune-$pid.gif"; $pdffile = "$tmpdir/Tune-$pid.pdf"; $pdfurl = "$tmpurl/Tune-$pid.pdf"; $pngfile = "$tmpdir/Tune-$pid.png"; $pngurl = "$tmpurl/Tune-$pid.png"; $svgfile = "$tmpdir/Tune-$pid.svg"; $midifil = "$tmpdir/Tune-$pid.midi"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Load our standard CSS info: $cssfile = "$docdir/FT_CSS.html"; &sendLog("$P: cssfile=\"$cssfile\"\n") if $V>1; if (-r $cssfile) { if (open(CSS,$cssfile)) { @css = ; close CSS; } else { &sendLog("$P: Can't read \"$cssfile\" (!$)\n") if $V>0; @css = (); } } else { @css = (); } $css = join("",@css); &sendLog("$P: css=\"\n$css\"\n") if $V>2; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ($scl = $scale) =~ s/^0*\.//; $fmt = sprintf "%02d",$scl; # Default format file &send_LW("scale='$scale' scl'='$scl fmt='$fmt'") if $V>1; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #%abctypes = ( # Types that need an intermediate .abc file # 'ABC' => 0, # 'EPS' => 1, # 'GIF' => 1, # 'HTML' => 1, # 'H5' => 1, # 'MIDI' => 1, # 'PDF' => 1, # 'PNG' => 1, # 'PS' => 1, # 'SVG' => 1, # 'TXT' => 0, # 'XXX' => 1, #); %wantFtr = ( # Types that get a footer line 'ABC' => 0, 'EPS' => 0, 'GIF' => 0, 'HTML' => 0, 'H5' => 1, 'MIDI' => 0, 'PDF' => 1, 'PNG' => 0, 'PS' => 1, 'SVG' => 0, 'TXT' => 0, # 'XXX' => 0, ); %fileDesc = ( 'abc' => 'ABC music file with the extracted tunes', 'eps' => 'Encapsulated PostScript, for inclusion in PS files', 'gif' => 'Graphics Interchange Format, the proprietary scan-line picture format', 'log' => 'Log file, useful mostly for debugging', 'midi'=> 'Musical Instrument Digital Interface, electronic version of the tunes', 'pdf' => 'Portable Data Format', 'png' => 'Portable Network Graphics, the open scan-line picture format', 'ps' => 'PostScript', 'h5' => 'HTML5', 'svg' => 'Scalable Vector Graphics format', 'txt' => 'Plain-text file with the extracted tunes', ); #%mimetypes = ( # What Content-type to send # 'ABC' => 'text/vnd.abc', # ABC's official MIME type # 'EPS' => 'application/postscript', # 'GIF' => 'text/html', # GIF file embedded in web page # 'HTML' => 'text/html', # Testing HTML5 output # 'MIDI' => 'audio/midi', # Plain MIDI file # 'PDF' => 'application/pdf', # 'PNG' => 'text/html', # PNG file embedded in web page # 'PS' => 'application/postscript', # 'H5' => 'text/html', # 'SVG' => 'text/html', # SVG file embedded in web page # 'TXT' => 'text/plain', # ABC sent as plain text # 'XXX' => 'text/html', # Experimental #); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # These files are kept by default: $keepgif = 1; $keeplog = 1; $keeppng = 1; $keeppdf = 1; $keepps = 1; $keepsvg = 1; # Other intermediate files will be deleted unless $V>2 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Check to see if there are too many copies of this program running. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # $cmd = "ps gawwux |grep 'tuneget' |egrep -v 'grep|gawwux'"; @copies = `$cmd`; $copies = int(@copies); &sendLog("$P: There are $copies copies of this program running:\n") if $V>0; for $psline (@copies) { &sendLog($psline) if $V>0; } if ($copies > $maxcopies) { &sendLog("$P: Only $maxcopies of this program are allowed; there are $copies.\n") if $V>0; &done(-1); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Our blacklist is an attempt to block the search bots that have hit us with # # attempts to return every tune in every format, sometimes many per second. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Is the client on our blacklist for any reason? &sendLog("ENV{PATH}: \"$ENV{PATH}\"\n") if $V>0; $Frq = $data{F} || '?' unless defined $Frq; $Urq = $data{U} || '?' unless defined $Urq; ($errs,$mesg) = chkRequest($RA,$UA,"F=\"$Frq\" U=\"$Urq\""); if ($errs > 0) { &sendEL_("### Ignore request from $RA [$mesg]") if $V>0; push @Send, "

Sorry; your address $RA matches an entry on our blacklist.\n"; push @Send, "

Reason: $mesg.\n"; push @Send, "

Send email to John Chambers for further information.\n"; &done(-$errs); } else { $RA = '?' unless defined $RA; $pathinfo = '?' unless defined $pathinfo; &sendEL_("--- Accept request from $RA for '$pathinfo'") if $V>1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if ($V>2) { push @Send, "


Here are our form elements:"; # $cgi = new CGI; @names = $cgi->param(); push @Send, "
"; for $n (sort @names) { if (@vals = $cgi->param($n)) { for $v (@vals) {print "
$n
\"$v\"\n"} } elsif ($v = $cgi->param($n)) { push @Send, "
$n
\"$v\""; } else { push @Send, "
$n
(NO VALUE)"; } } push @Send, "
"; push @Send, "
Here are our environment variables:"; push @Send, "
"; for $e (sort keys %ENV) { $v = $ENV{$e}; push @Send, "
$e
$v"; } push @Send, "
"; if ($rfrr = $ENV{'HTTP_REFERER'}) { push @Send, "
Referer: $rfrr\n" if $V>0; } else { push @Send, "
No referer.\n" if $V>0; } push @Send, "
"; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Look for some things in the form data: $title = &tText(($data{T} || $data{title}), $title); $V = &tInt($data{V}, $V); $Vsrc = 'data{V}' if defined $data{v}; $Prq = &tWord($data{P} || $data{pat} || $data{pattern}) || ''; $Trq = &tWord($data{T}); $Xrq = &tNum($data{X}, '0'); &sendLog("Is S in form data?\n"); $scale = &tNum($S = $data{S}, $scale); &sendLog("V=$V S='$S' scale='$scale'\n") if $V>1; ($scl = $scale) =~ s/^0*\.//; &send_LW("V=$V scl='$scl' scale='$scale'\n") if $V>1; $fmt = "_$scl"; $Ftr = 0; # Whether we want footer lines in the output $Fmt = '?'; $Fmts = ''; if ($x = $data{F} || $data{select}) { $Fmt = &tWord($x); $Ftr += $wantFtr{$Fmt}; $Fmts{$Fmt} = 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Check for known bots, and reject their request if they've asked for a tune # # match. We do respond to them if they've requested our search page, mostly # # so that Googlebot can call us and get our keywords. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # unless (defined $botpat) { $botpat = # Pattern to recognize bots in UA '[-\w]*Google.*bot*|Yahoo|msnbot|BecomeBot'; &sendLog("Set botpat=/$botpat/\n") if $V>0; } &sendLog("$P: botpat=/$botpat/\n") if $V>0; if ($UA =~ /$botpat/i) { $botname = $&; &now(); $msg = "[$ymd $hms] $$ $P: Request from $RA \"$botname\" bot for \"$Fmt\" ignored."; &sendAll($msg); # Tell errlog, log and client &done($exitstat); } &sendLog("ENV{PATH}: \"$ENV{PATH}\"\n") if $V>0; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if (defined($data{fABC})) {$Fmts{ABC} = 1; $Ftr += $wantFtr{ABC}} if (defined($data{fEPS})) {$Fmts{EPS} = 1; $Ftr += $wantFtr{EPS}} if (defined($data{fGIF})) {$Fmts{GIF} = 1; $Ftr += $wantFtr{GIF}} if (defined($data{fH5})) {$Fmts{H5} = 1; $Ftr += $wantFtr{H5}} if (defined($data{fHTML})) {$Fmts{HTML} = 1; $Ftr += $wantFtr{HTML}} if (defined($data{fMIDI})) {$Fmts{MIDI} = 1; $Ftr += $wantFtr{MIDI}} if (defined($data{fPDF})) {$Fmts{PDF} = 1; $Ftr += $wantFtr{PDF}} if (defined($data{fPNG})) {$Fmts{PNG} = 1; $Ftr += $wantFtr{PNG}} if (defined($data{fPS})) {$Fmts{PS} = 1; $Ftr += $wantFtr{PS}} if (defined($data{fSVG})) {$Fmts{SVG} = 1; $Ftr += $wantFtr{SVG}} if (defined($data{fTXT})) {$Fmts{TXT} = 1; $Ftr += $wantFtr{TXT}} @Fmts = sort keys %Fmts; # Names of selected formats $Fmts = join(',',@Fmts); # Printable list of formats $FmtN = int(@Fmts); # Number of formats # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Is there a title in the requested URL? &sendLog("Check data{U} ...\n") if $V>0; if ($Urq = $data{U}) { &sendLog("Urq='$Urq'\n") if $V>0; if ($Urq =~ m"^.*/([^-.]+)") { $title = $1; &sendLog("title=\"$title\" [from URL]\n") if $V>0; $title = &tText($1); # Untaint the tune-title part of the URL &sendLog("title=\"$title\" [from tText()]\n") if $V>0; } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Send the HTML header # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Send accumulated debugging stuff: while ($line = shift @Send) { $line =~ s/[\r\s]+$/\n/; # Some routines include the \n; others don't **shrug** &sendWeb("$line\n"); # Now there's exactly one \n at the end of each line } $title =~ s/_/ /g; # In case the title is a file name with underscores &sendWeb("\t$title [$Fmts] $Prq\n"); &sendWeb("\t\n"); &sendWeb("\t\n"); &sendWeb("\t\n"); # Does this suffice in general? #----Web("\t\n"); # For some small-screen gadgets #----Web("\t\n"); # For iPad Safari? &sendWeb("\t\n"); #----Web("\t\n"); # We now include the CSS inline &sendWeb("\n\n\n"); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # It is now safe to send messages to the client! &sendLog("Called: $P+$cgiloc $$\n") if $V>1; &send_LW("From: $RA V=$V ($Vwhy)") if $V>1; &send_LW("Formats: $Fmts scl='$scl' scale='$scale' hres='$hres' vres='$vres'") if $V>1; if ($V>1) { for $f (sort keys %Fmts) {&sendLog("Fmts{$f}='$Fmts{$f}'\n")} } &sendLog("Ftr=\"$Ftr\"\n") if $V>1; # Look for a URL in the form args: $Sels = 0; # Number of selections $URL = ''; # Requested URL if ($URL = $data{U}) { &sendLog("data URL='$URL'\n") if $V>1; $URL =~ s"^//*"http://$SV/"; # Expand "local" URLs &sendLog("expd URL='$URL'\n") if $V>1; ($URL,$uProt,$uHost,$uFile) = &tURL($URL); &sendLog("uProt='$uProt'\n") if $V>1; &sendLog("uHost='$uHost'\n") if $V>1; &sendLog("uHost='$uHost'\n") if $V>1; if ($V>1) { &sendLog("URL=\"$URL\"\n"); &sendLog("uProt=\"$uProt\"\n"); &sendLog("uHost=\"$uHost\"\n"); &sendLog("uFile=\"$uFile\"\n"); } $Xrq = &tNum($data{X}, '0'); &sendLog("X: \"$Xrq\"") if $V>1; $SelKey[1] = $SelOrd[1] = $Select{1} = 1; # Fake a selection $SelNdx[1] = $Xrq; $SelTtl[1] = $Trq; $SelTTL[1] = $Trq; $SelURL[1] = $URL; ++$Sels; &sendLog("Find X:$SelNdx[1] \"$SelTtl[1]\"\n") if $V>0; # && defined($SelNdx[1]) && defined($SelTtl[1]); if ($V>2) { &sendWeb(""); &sendWeb(" ") if $SelKey[1]; &sendWeb(" ") if $SelOrd[1]; &sendWeb(" ") if $SelNdx[1]; &sendWeb(" ") if $SelTtl[1]; &sendWeb(" ") if $SelTTL[1]; &sendWeb(" ") if $SelURL[1]; &sendWeb("
Ord 1$SelKey[1]
Ord 1$SelOrd[1]
Ndx 1$SelNdx[1]
Ttl 1$SelTtl[1]
TTL 1$SelTTL[1]
URL 1$SelURL[1]
"); } &sendLog("$Sels selections so far.\n") if $V>1; } else { &sendLog("No URL in form args.\n") if $V>1; $URL = ''; } &sendLog("From: $RA $ymd $hms UTC pid=$pid V=$V Sels=$Sels.\n") if $V>1; &chkdef($Fmts,'Fmts'); &chkdef($Trq,'Trq'); &chkdef($Xrq,'Xrq'); &sendLog("Fmts=$Fmts T=\"$Trq\" X=$Xrq\n"); &sendLog("URL=\"$URL\"\n"); #lsend("mimetype=\"$mimetype\"\n") if $V>2; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Here we attempt to decide whether we should produce the "footer" line at # # the bottom of each page giving the date and source URL for the page. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # $Ftr += &tNum($data{Ftr},0); &sendLog("Ftr=\"$Ftr\"\n") if $V>1; $PSftr = $Ftr ? "|PSftr '%D %T' $URL %P" : ''; &sendLog("PSftr=\"$PSftr\"\n") if $V>1; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # $UA = $data{UA} || $ENV{HTTP_USER_AGENT} || 'Unknown'; # What sort of client? &sendLog("P='$P'\n") if $V>1; &sendLog("SV='$SV'\n") if $V>1; &sendLog("RA='$RA'\n") if $V>1; &sendLog("UA='$UA'\n") if $V>1; &sendLog("RA='$RA'\n") if $V>1; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # chomp($cwd = `pwd`); #$data{indexdir} = $indexdir; &sendWeb("P=$P PID=$pid
\n") if $V>1; &sendLog("Process form data:\n") if $V>0; for $key (sort keys %data) { $val = $data{$key}; &sendLog("\t$key = \"$val\"\n") if $V>1; $val =~ /^[\r\s]*(.*)[\r\s]*$/; $val = $1; if ((($N) = ($key =~ /^Sel(\d+)/)) && $val) { &sendWeb("Sel $N:
    \n") if $V>1; # $val =~ /^[\r\s]+//; # $val =~ s/[\r\s]+$//; $SelKey[$N] = &keyval($val); $SelOrd[$N] = $SelNdx[$N] || 0; $SelNdx[$N] = $data{"Ndx$N"} || ''; $SelTtl[$N] = $data{"Ttl$N"} || ''; $SelTTL[$N] = $data{"TTL$N"} || ''; $SelURL[$N] = $data{"URL$N"} || ''; ++$Sels; # if (($x,$y) = ($val =~ /^(\s*)(\d+)[\r\s]*$/)) { # Is value an integer? # $val = sprintf("%8d",$y); # } $Select{$SelKey[$N]} = $N; # Index of selection ordinal values &sendLog("Find $SelOrd[$N] '$SelKey[$N]' X:$SelNdx[1] $SelTtl[1]") if $V>1 && defined($SelOrd[$N]) && defined($SelNdx[1]) && defined($SelTtl[1]); if ($V>1) { &sendLog("\tSel$N Ord=$SelOrd[$N]\n"); &sendLog("\tSel$N Ord=$SelKey[$N]\n"); &sendLog("\tSel$N Ndx=$SelNdx[$N]\n"); &sendLog("\tSel$N Ttl=$SelTtl[$N]\n"); &sendLog("\tSel$N TTL=$SelTTL[$N]\n"); &sendLog("\tSel$N URL=$SelURL[$N]\n"); &sendWeb("
  • Ord$N: '$SelOrd[$N]' <
  • \n"); &sendWeb("
  • Ord$N: '$SelKey[$N]'
  • \n"); &sendWeb("
  • Ndx$N: '$SelNdx[$N]'
  • \n"); &sendWeb("
  • Ttl$N: '$SelTtl[$N]'
  • \n"); &sendWeb("
  • TTL$N: '$SelTTL[$N]'
  • \n"); &sendWeb("
  • URL$N: '$SelURL[$N]'
  • \n"); } &sendWeb("
\n"); &sendLog("$Sels selections so far.\n") if $V>1; } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Some on/off options: $nopt = (tInt($data{'nopt'}, 0) > 0) ? '+n' : ''; # Show notes $xopt = (tInt($data{'xopt'}, 0) > 0) ? '+x' : ''; # Show index numbers $copt = (tInt($data{'copt'}, 0) > 0) ? '+c' : ''; # Continueall (Ignore staff breaks) &sendLog("Flags: copt='$copt' nopt='$nopt' xopt='$xopt' [from data]\n"); # if $V>0; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # The N param may be used to append a file name to the end of the URL. This # # is used by some browsers as the local file name if the file is written to # # disk. Unfortunately, it doesn't seem to work very well on MS Windows or # # Macs. Or maybe we just don't know the exact incantation to make it work. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #$Nopt = &tWord($data{N}); #($SaveAs = $Nopt) =~ s"^/+""; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # The S param is used to give a scaling factor. This is fed to abc2ps to get # # the desired size of staffs and notes. It mostly doesn't effect text. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendLog("V=$V Get scale ...\n"); # if $V>0; $scale = '0.65' unless defined $scale; &sendLog("V=$V Got scale='$scale'\n"); # if $V>0; $Sopt = &tNum($data{S}, "$scale") unless defined $Sopt; &sendLog("V=$V scale='$scale' Sopt='$Sopt'\n"); # if $V>1; if ($Sopt =~ /^\.(\d+)$/) { # .DD $Sopt = sprintf "0.%02d",$1; &sendLog("Sopt: .DD '$Sopt'\n") if $V>2; } elsif ($Sopt =~ /^(\d+)\.(\d)$/) { # D.D $Sopt = sprintf "%d.%01d0",$1,$2; &sendLog("Sopt: D.DD '$Sopt'\n") if $V>2; } elsif ($Sopt =~ /^(\d+)\.(\d+)$/) { # D.DD $Sopt = sprintf "%d.%02d",$1,$2; &sendLog("Sopt: D.DD '$Sopt'\n") if $V>2; } elsif ($Sopt =~ /^(\d*)(\d\d)$/) { # DDD $Sopt = "$1.$2"; &sendLog("Sopt: DDD '$Sopt'\n") if $V>2; } elsif ($Sopt =~ /^(\d+)$/) { # DD.. $Sopt = "$1.00"; &sendLog("Sopt: DD '$Sopt'\n") if $V>2; } else { &sendLog("Can't parse Sopt=\"$Sopt\"\n"); &sendWeb("Can't parse Sopt=\"$Sopt\"
\n"); $Sopt = "0.65"; &sendLog("Sopt: ?? '$Sopt'\n") if $V>2; } $sopt = " +s $Sopt"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # The sbrk param is used to select a scheme for determining staff breaks. If # # missing, we use the abc standard: end-of-line is end-of-staff, with \ # # (backslash) used for "continued on next line". More values are: # # # # +b break at all line ends; ignore \ continuations # # +c continuous: ignore line ends; abc2ps determines staff breaks # # -c -b default: honor line ends and \ continuations # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if (defined($data{sbrk}) && ($data{sbrk} =~ /([-+])\s*([bc]+)/)) { $sbrk = "$1$2"; &sendLog("Flags: sbrk='$sbrk' copt='$copt'") if $V>1; if ($sbrk =~ /([-+]c)/) { $copt = $1; &esend ("Flags: sbrk='$sbrk' copt='$copt'") if $V>1; } } else { $sbrk = ''; # Use default staff-break behavior &sendLog("Flags: sbrk='$sbrk' copt='$copt' [no sbrk]") if $V>1; } &sendLog("Flags: sbrk='$sbrk' copt='$copt'\n") if $V>1; $all = ($Xrq ne '' && $Xrq ne '0') ? 0 : 1; &send_LW("Scale: scale='$scale'") if $V>1; if (($ipart,$fpart) = ($scale =~ m/^(\d*)\.(\d*)$/)) { &sendLog("Scale: scale='$scale' ipart='$ipart' fpart='$fpart'\n") if $V>1; $scl = sprintf("%.2f",$scale); &send_LW("Scale0 scale='$scale' scl='$scl'") if $V>2; $scl =~ s/^0+//; &send_LW("Scale1 scale='$scale' scl='$scl'") if $V>2; $scl =~ s/\.//; &send_LW("Scale2 scale='$scale' scl='$scl'") if $V>2; $fmt = "_$scl"; &send_LW("Scale4 scale='$scale' scl='$scl' fmt='$fmt'") if $V>2; } else { &send_LW("Scale: scale='$scale' not understood.\n") if $V>0; $scl = $scale; # Maybe this'll work? &send_LW("Scale: scl='$scl'\n"); # if $V>2; $fmt = '_$scl.fmt' } &send_LW("Format: scale='$scale' scl='$scl' fmt='$fmt' Fmts='$Fmts' V=$V.\n") if $V>1; &sendLog("sbrk='$sbrk' Sopt='$Sopt' sopt='$sopt' Xrq=$Xrq scl='$scl' fmt='$fmt'\n") if $V>0; #&sendLog("Nopt='$Nopt' SaveAs='$SaveAs' \n") if $V>0; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Some validity tests on args: if ((-d $tmpdir) && (($x,$y) = ($tmpdir =~ m"^/+(\w+)/([-\w/]+)$"))) { $tmpdir = "/$x/$y"; } else { &sendLog("Bad tmp dir \"$tmpdir\"\n"); $tmpdir = 'tmp'; # Try to use local tmp dir } if (($y,$m,$d) = ($ymd =~ /(\d\d\d\d)(\d\d)(\d\d)/)) { $ymd = "$y$m$d"; } else { &sendLog("$P called with ymd='$ymd' hms='$hms'\n") if $V>0; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Register this request in the request log: $Fdsc = ($FmtN > 1) ? 'sel' : $Fmts; &abclogreq($P,$$,$tmpdir,$RA,$ymd,$hms,$Xrq,$Fdsc,$Trq,$URL); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # We do a sort of two-pass extraction of tunes. First, the raw text is # appended to @tune, attempting to extract just one desired tune. Then @tune # is appended to @tunes, with possible editing to correct for common # problems. &sendLog("$Sels selections total.\n") if $V>1; if ($Sels) { for $ord (sort keys %Select) { $sel = $Select{$ord}; &sendLog("SEL $sel is ORD '$ord'\n") if $V>1; $selURL = $SelURL[$sel] || ''; # URL to search for selected tune $selTtl = $SelTtl[$sel] || ''; # Title of selected tune (full) $selTTL = $SelTTL[$sel] || ''; # Title reduced to canonical form $selNdx = $SelNdx[$sel] || ''; # Index of selected tune $selOrd = $SelOrd[$sel] || ''; # Ordinal position of selected tune $selKey = $SelKey[$sel] || ''; # Sort key value for selected tune &sendLog("ORD $sel selOrd='$selOrd'\n") if $V>4; &sendLog("ORD $sel selKey='$selKey'\n") if $V>4; &sendLog("ORD $sel selNdx='$selNdx'\n") if $V>1; &sendLog("ORD $sel selTtl='$selTtl'\n") if $V>1; &sendLog("ORD $sel selTTL='$selTTL'\n") if $V>1; &sendLog("ORD $sel selURL='$selURL'\n") if $V>1; } } elsif ($tune = $data{data}) { @tunes = split("\n",$tune); if ($V>1) { &sendLog("Called with POST data:\n"); for $line (@tunes) {&send_LW("ABC: \"$line\"\n")} } } elsif ($Sels > 0) { &send_LW("Called with $Sels selections.\n") if $V>1; } elsif ($formvars > 0) { &send_LW("### Called with no parameters ###") if $V>0; done(1); } else { &sendLog("### Called without a URL ###\n"); &sendWeb("

Called without a URL\n"); done(1); } ++$gotONeills if $chkONeills && index($URL,$ONeillsURL) >= 0; if ($V>1) { &sendLog("Environment:\n"); for $k (sort keys %ENV) {$y = $ENV{$k}; &sendLog("\t$k\t$y\n")} } if ($V>0) { &sendLog($idline) if $V>1; &sendLog("D:\t$ymd $hms\n"); for $H ('F','N','T','U','X') { &sendLog("$H:\t$data{$H}\n") if defined $data{$H}; } } if ($V>1) { &sendLog("Data:\n"); for $k (sort keys %data) {$y = $data{$k}; &sendLog("\t$k\t$y\n")} if ($x = $ENV{PATH_INFO}) {&sendLog("PATH_INFO:\t$x\n");} } &sendLog("Change to '$cgidir'") if $V>2; chdir $cgidir; ($cwd = `pwd`) =~ s/[\r\s]+$//; &sendLog("Changed to '$cwd'\n") if $V>1; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Now we attempt to read the URLs and extract the requested tune from each. # # We accumulate a single tune in @tune, then, if it is acceptable, we append # # it to @tunes. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # $tunesrc = '?'; # Where we found the tune: I=input C=cache F=file U=URL if (@tunes) { &sendLog("We have a tune from stdin.\n") if $V>1; for $line (@tunes) { &abcline($line); } $tunesrc = 'I'; } &send_LW("We have $Sels selected tunes:\n") if $V>1; if ($V>1) { for $ord (sort keys %Select) { $sel = $Select{$ord}; $selNdx = $SelNdx[$sel]; # Index of selected tune $selKey = $SelKey[$sel]; # Sort key of selected tune &sendLog("=== Ord sel='$sel' Key='$ord' selKey='$selKey' selNdx='$selNdx'\n"); } } $newNdx = 0; # For generating sequential tune indexes &sendWeb("

\n") if $V>1; $tunenumber = 0; selection: $outNdx = 0; # Index of tune in output (sequential counter) for $ord (sort keys %Select) { ++$tunenumber; ++$outNdx; $sel = $Select{$ord}; &sendLog("\n Selection $tunenumber tune $sel has sort key $ord.\n") if $V>1; $selURL = $SelURL[$sel]; # URL to search for selected tune $selTtl = $SelTtl[$sel]; # Title of selected tune (full) $Trq = $selTTL = $SelTTL[$sel]; # Title reduced to canonical form $Xrq = $selNdx = $SelNdx[$sel]; # Index of selected tune $selOrd = $SelOrd[$sel]; # Ordinal position of selected tune $selKey = $SelKey[$sel]; # Sort key of selected tune &sendLog("\tselURL: '$selURL'\n") if $V>2; &sendLog("\tselTtl: '$selTtl'\n") if $V>2; &sendLog("\tselTTL: '$selTTL'\n") if $V>2; &sendLog("\tselNdx: '$selNdx'\n") if $V>2; &sendLog("\tselOrd: '$selOrd'\n") if $V>2; &sendLog("\tselKey: '$selKey'\n") if $V>2; $selURL =~ s"^/+"http://$SV/"; # Expand "local" URLs $selURL =~ s"^http:/+"http://"i; # Some links get this wrong $selURL =~ s"/http:/+"/http/"i; # Rewrite internal http:// "directories" (web.archive.org kludge) $selURL =~ s"/+\./+"/"g; # Simplify remove /./ etc. from URL &sendWeb("
Sel $ord:
Get X:$selNdx T:$selTTL U:\"$selURL\"
\n") if $V>1; &sendLog("Sel $ord: Get X:$selNdx T:$selTTL U:\"$selURL\"\n") if $V>1; $lines = 0; if (($selNdx > 0) && ($lines = &fromCache($selNdx,$selTTL,$selURL))) { &sendLog("Got $lines-line tune from cache.") if $V>1; &endtune(); # Validate it and copy it to @tunes $tunesrc = 'C'; } else { &sendLog("Getting tune from original file because selNdx=$selNdx and lines=$lines ...") if $V>0; &sendLog("Sel $sel URL='$selURL'\n") if $V>1; if (($prot,$hnam,$file) = ($selURL =~ m"(\w+)://([-_\w.:]+)/(.*)")) { &cfgload("cfg/$hnam",$hnam); $selURL = "$prot://$hnam/$file"; } else { &send_LW("Bad host name in \"$selURL\"\n") if $V>0; } $hnam = &tFQDN($hnam); # Untaint the host name $encURL = &URLenc($selURL); # Encode all funny chars in URL [jc 20060920] $getsrc = "C:$hnam"; if (defined($getcmd = $Getcmd{$getsrc})) { # print "TAINTED: getcmd=\"$getcmd\")
\n" if is_tainted($getcmd); &sendLog("Getcmd{$getsrc}='$Getcmd{$getsrc}'\n") if $V>1; $getcmd .= " '$encURL'"; &send_LW("$P: getcmd \"$getcmd\"") if $V>0; } else { $getcmd = "webcat +TH -T60 '$encURL'"; $getsrc = 'default'; &sendLog("$P: Default getcmd \"$getcmd\"") if $V>0; } &msend("$P: getcmd=\"$getcmd\" [$getsrc]") if $V>1; print "getcmd='$getcmd'
\n" if $V>1; if ($getpid = open(U,"$getcmd |")) { &sendLog("$P: Opened getcmd for reading, pid=$getpid, Fmts='$Fmts'.\n") if $V>0; $idline = "F:$encURL\t $ymd $hms UT\n"; &sendLog($idline) if $V>1; $Ubuf = ''; # Input buffer for U @tune = (); # For accumulating one tune $HTML = 0; # Set true if it's an HTML file $URLhdr = 1; # True while we're reading HTTP headers $alines = 0; # Accepted lines $hlines = 0; # Header lines $dlines = 0; # Document lines $inabc = 0; # True when we're inside an abc tune $insel = 0; # True when we're inside a selected tune $Tgood = 0; # True when tune's title matches $Xgood = 0; # True when tune's index matches &sendLog("Reading ...\n") if $V>2; $X = undef; # Don't know any index number yet $HTTPerrcode = 0; # Note HTTP error codes $HTTPerrmsg = ''; # and error message line: while ($line = &Uline()) { $line =~ s/[\n\r\s]+$/\n/; &sendLog("LINE: $line") if $V>2; if ($URLhdr) { ++$hlines; &sendLog("HDR: $line") if $V>6; if ($line =~ /^\s*$/) { $URLhdr = 0; } else { if (&hdrline($line) < 0) { &sendLog("$P: CAN'T GET '$encURL'\n") if $V>0; &sendWeb("CAN'T GET '$encURL'
\n") if $V>0; close U; # Give up on it } } next line; } ++$dlines; &send_LW("Line $line") if $V>4; &sendLog("Hdr: $line") if $V>0 && ($line =~ /^\w:/); # if ($selNdx < 1 && !$selTTL) # Return entire file in @tune (old) if ($selNdx < 1) { # Return entire file in @tune for X:0 &send_LW("Sending entire file.") if $V>3; $Xgood = $Tgood = $inabc = 1; if ($line =~ /^X:\s*(\d+)/) { $dbgX = $X = $1; # Remember the index for later use ++$newNdx; # Output this index number $line = "\nX:$outNdx\n"; &sendLog("--- X: $X -> $outNdx\n") if $V>0; ++$outNdx; } elsif ($line =~ /^T:\s*(.*)$/) { $dbgT = $Ttl = $1; &sendLog("--- T: $Ttl\n") if $V>0; unless (defined $X) { $X = $selNdx; # Default index is the requested index &sendLog("X header missing, using X:$X\n"); &tuneline('', "X: $outNdx"); # Add missing index to tune $dbgX = $X; # Note the index for debugging } $dbgX = '?' unless defined $dbgX; $newNdx = '?' unless defined $newNdx; $H = '?' unless defined $H; $tunesrc = 'F'; ($mURL = $selURL) =~ s"^http/+"http://"; # ($mURL = $selURL) =~ s"^cache/+"http://"; &match($tunesrc,"X:$dbgX",$outNdx,$H,"T:$Ttl",$mURL); } else { &sendLog("--- All\n") if $V>2; } &tuneline($line); next line; } if ($line =~ m"^X:\s*([\d/.]+)") { # X: starts new tune &sendLog("Extra X:$1 (was $dbgX)\n") if $dbgX && $V>1; $X = $1; $inabc = 1; # Start of ABC tune $insel = (($selNdx == 0) || ($selNdx == $X)) ? 1 : 0; &sendLog("\tX:$X\n") if $V>0; $Tgood = 0; $Xgood = (($selNdx < 1) || ($selNdx == $X)) ? 1 : 0; &sendLog("\tselNdx=\"$selNdx\" X=$X Xgood=$Xgood.\n") if $V>0; if ($V>2 && $Xgood) { &send_LW("Matched X:$X\n"); } $T = ''; &tuneline('', "X:$outNdx"); # X: line starts current tune $dbgX = $X; # Note the index number next line; } if (($H,$Ttl) = ($line =~ /^([PT]):\s*(.*)/)) { # T: or P: line may start new tune &DT(); &sendLog("+++ $H:$Ttl [$ymd $hms]\n") if $V>0; if (($H eq 'P') && $T) { # &sendLog("P: $H:$Ttl ignored because we have a T title.\n") if $V>2; &tuneline($line) if $Tgood; next line; } &sendLog("Got $H:$Ttl\n") if $V>0; unless (defined $X) { $X = $selNdx; # Default index is the requested index &sendLog("X header missing, using X:$X\n"); &tuneline('', "X: $outNdx"); # Add missing index to tune $dbgX = $X; # Note the index for debugging } $inabc = 1; # Start of ABC tune $insel = (($selNdx == 0) || ($selNdx == $X)) ? 1 : 0; $Xgood = (($selNdx < 1) || ($selNdx == $X)) ? 1 : 0; # unless (@tune) { # # ++$newNdx; # Output this index number # # &tuneline(''); # Blank line before tune # } $Ttl =~ s/[\r\s]+$//; # Trim white stuff $gotTtl = &AdjTitle($Ttl); # Convert to InterCaps canonical form $gotTtl =~ s/[^A-Za-z0-9]//g; # Strip out all non-alpha chars $gotTTL = uc($gotTtl); # All-caps version &sendLog("\tTitle gotTtl=\"$gotTtl\" is adjusted title.\n") if $V>0; if ($selTTL) { # Did we get a title in the request? &sendLog("\tselTTL=\"$selTTL\" gotTTL=\"$gotTTL\" \n") if $V>2; &sendLog("\tTrq=\"$Trq\"\n") if $V>0; if ($gotTTL =~ /$Trq/) { &sendLog("X:$X Title \"$Ttl\" matches \"$gotTTL\"\n") if $V>0; $Tgood++; if ($X == $Xrq) { &send_LW("Found X:$X \"$Ttl\" matches \"$Trq\"") if $V>0; $tunesrc = 'U'; ($mURL = $selURL) =~ s"^http/+"http://"; # ($mURL = $selURL) =~ s"^cache/+"http://"; &match($tunesrc,"X:$X",'[N]','[H]',"$H:$Ttl",$mURL); } else { &send_LW("Mismatch: X:$X doesn't match requested X:$Xrq") if $V>0; } } else { &sendLog("\tTitle tTtl=\"$Ttl\" does not match gotTTL=\"$gotTTL\"\n") if $V>0; } } elsif (defined $selNdx) { # [jc 20060615] Fix bug found by Simon Wascher &sendLog("Selecting only on X:$selNdx\n") if $V>2; $Tgood = 1; # Accept all titles; select only on index } else { &send_LW("No selection criteria found.") if $V>0; $Xgood = $Tgood = 1; # Accepting all titles } if ($Tgood) { &sendLog("Tune is good.\n") if $V>0; unless (@tune) { # Can happen if X: and T: both missing &tuneline('',"X:$outNdx") if defined $X; $dbgX = $X; } &tuneline($line); } else { &sendLog("Tune not accepted.\n") if $V>0; } next line; } next line unless $inabc; # Drop anything not in a tune # Any ABC lines except X or T: if ($HTML) { if ($line =~ m"^\s*<(/*\w+)") { # Initial '<$1> tag (HTML=$HTML).") if $V>1; next line; } } $tlines = int(@tune); &sendLog("\t$tlines lines at EOT\n") if $V>2; if ($line =~ /^\s*$/) { # Null line ends tune next line if $HTML; # except in HTML, where blank lines are ignored &sendLog("\tTgood=$Tgood Xgood=$Xgood selTTL=\"$selTTL\" $tlines lines at EOT\n") if $V>2; &endtune() if @tune; if ($Xgood && $Tgood) { &sendLog("X: $X acceptable.\n") if $V>2; next line if $all; # Accepting all tunes &sendLog("\tEnd on blank line.") if $V>2; last line; } &sendLog("Continuing with file ...\n") if $V>2; $inabc = $Xgood = $Tgood = 0; # Re-init for next tune $X = undef; # Don't know index number now next line; } elsif (($H,$Ttl) = ($line =~ /^([TP]):\s*(.*)$/)) { &sendLog("\tX: \"$X\" T: \"$1\"\n") if $V>1; # next line if ($T && $1 eq 'P'); if ($H eq 'T' || ($H eq 'P' && !$T)) { # Check all T: lines and P: if no T: lines $Ttl =~ s/[\r\s]+$//; # Trim trailing white stuff $T = &AdjTitle($Ttl); # Convert to InterCaps canonical form $T =~ s/[^A-Za-z0-9]//g; # Strip out all non-alpha chars } if ($Trq) { # Did we get a title in the request? lsend("\t$X T=\"$T\"\n") if $V>1; lsend("\tTTL=\"$selTTL\"\n") if $V>1; $selTTL = uc($T); # All-caps version &sendLog("\tTitle selTTL=\"$selTTL\" is canonical title.\n") if $V>0; if ($selTTL =~ /$Trq/) { &sendLog("X:$X Title \"$selTtl\" matches \"$Trq\"\n") if $V>1; $Tgood++; } else { &sendLog("\tTitle selTTL=\"$selTTL\" does not match Trq=\"$Trq\"\n") if $V>2; } } else { lsend("\tNo title found in tune $X.\n") if $V>0; # $Tgood++; # No requested title; accept all of them } } &sendLog("\tTgood=$Tgood Xgood=$Xgood selTTL=\"$selTTL\"\n") if $V>2; if ($Xgood || $Tgood) { &tuneline($line); } } &sendLog("Fmts='$Fmts' [EOF on ABC]\n") if $V>2; $alines = int(@tune); &sendLog("EOF with $alines of $dlines lines accepted.\n") if $V>1; if ($dlines < 1) { &send_LW("No data in '$selURL'") if $V>0; } close U; $exit_value = $? >> 8; $signal_num = $? & 127; if ($?) { &send_LW("Got status $exit_value for '$selURL'") if $exit_value && $V>1; &send_LW("Got signal $signal_num for '$selURL'") if $signal_num && $V>1; } &send_LW("Got HTTP status $HTTPerrcode $HTTPerrmsg for '$selURL'") if $HTTPerrcode>=400 && $V>0; &sendLog("\tHTTPerrcode=$HTTPerrcode HTTPerrmsg=$HTTPerrmsg\n") if $V>2; &endtune() if @tune; &sendLog("We now have " . int(@tunes) . " lines in \@tunes.\n") if $V>2; } else { $err = "Can't run \"$getcmd\" ($!)"; &sendLog("$P: $err\n") if $V>0; &sendWeb("

$err

\n"); &done($!); } &sendLog("$P: Done with fetch of original file.\n") if $V>0; } if (@tunes) { &sendLog("\tEnd of non-empty tune.\n") if $V>2; &endtune() if @tune; &sendLog("There are " . int(@tunes) . " lines in \@tunes.\n") if $V>2; } else { &send_LW("X:$selNdx not found in $selURL") if $V>0; } } &sendWeb("

\n") if $V>1; #&sendLog("mimetype=\"$mimetype\"\n") if $V>2; #sub is_tainted { ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ## Taintedness test from the perlsec man page: # return ! eval { # join('',@_), kill 0; # 1; # }; #} # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Now we write the matched tunes in @tunes to the $abcfile. This file will be # # fed to program that convert ABC to PS, HTML5, MIDI, or maybe other formats. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # unless (open(ABC,">$abcfile")) { &sendWeb("Can't write \"$abcfile\" ($!)\n"); &sendLog("Can't write \"$abcfile\" ($!)\n"); &done(1); } &sendLog("Write " . int(@tunes) . " lines to \"$abcfile\"\n") if $V>2; print ABC @tunes; close ABC; &sendLog("Fmts='$Fmts' [closed ABC]\n") if $V>2; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Because some clients have problems with the text/vnd.abc MIME type, we also # # link the .abc file to a .txt file, which will be sent as text/plain. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # unlink($txtfile) if -f $txtfile; if (link($abcfile,$txtfile)) { &sendLog("Linked $abcfile to $txtfile\n") if $V>1; } elsif ($V>0) { $errmsg = "$P: Can't link \"$abcfile\" to \"$txtfile\" ($!)"; &sendLog("$errmsg\n"); print STDERR "]$errmsg\n"; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Send the client a list of the tunes (titles) that we found. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendLog("client='$client' scl='$scl' scale='$scale' fmt='$fmt'") if $V>1; if (@matches) { if ($V>1 || $showmatches) { &sendWeb("Titles found:
\n") if $V>1; &sendWeb("
\n") if $useCenter; &sendWeb("\n") if $V>1; for $x (@matches) { &sendLog("UTF8: x=\"$x\"\n") if $V>1; $y = &abc2utf8($x); &sendLog("UTF8: y=\"$y\"\n") if $V>1; &sendWeb("\t" . $y . "\n") if $V>1; } &sendWeb("
\n") if $V>1; &sendWeb("
\n") if $useCenter; } } else { &sendWeb("

No titles recognized.\n") if $V>1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # The simplest client request is for the matched tune(s) in either ABC or TXT # # format. We just send the contents of @tunes, HTML-encoded of course. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if ($Fmts{ABC} || $Fmts{TXT} || $Fmts{HTML}) { &sendWeb("
\n");
	for $line (@tunes) {
		$line =~ s/&/\&/g;	# Encode &
		$line =~ s//\>/g;	# Encode >
		&sendWeb($line);
	}
	&sendWeb("\n
\n"); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # We use the scaling factor to choose a format file. This may change ... # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if ($scl) { # Handle scaling factor # $sclSVG = $scl . 'SVG'; if (-f ($Ffil = "fmt/_$scl.fmt")) { $Fopt = $scl ? "+Ffmt/_$scl" : ''; # Format option &send_LW("Format file $Ffil exists\n") if $V>1; } else { &send_LW("No format file $Ffil\n") if $V>0; $Fopt = ''; } } else { &send_LW("Invalid scale '$scl'\n") if $V>1; $Fopt = ''; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # For the following formats, we first converted the ABC to PostScript, then # # we convert the PS to the requested format(s). # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendWeb("
\n") if $V>0; if ($Fmts{PS} || $Fmts{GIF} || $Fmts{PNG} || $Fmts{PDF}) { &sendLog("Output formats $Fmts in PS/GIF/PNG/PDF/SVG\n") if $V>0; # if ($testing && (($URL =~ '/test/') || ($URL =~ "/src/$a2p/"))) { # $ENV{"V_$a2p"} = '3'; # $ENV{"D_$a2p"} = '3'; # } &chkdef($Fmts,'Fmts'); &chkdef($scl,'scl'); &chkdef($fmt,'fmt'); &chkdef($Fopt,'Fopt'); &chkdef($hres,'hres'); &chkdef($vres,'vres'); &sendLog("Fmts='$Fmts' scl='$scl' fmt='$fmt' Fopt='$Fopt' hres=$hres vres=$vres\n") if $V>0; &sendLog("Flags: copt='$copt' nopt='$nopt' xopt='$xopt'\n") if $V>0; # &sendLog("Nopt='$Nopt' SaveAs='$SaveAs' \n") if $V>0; # $pscmd = "($a2p $abcfile $Fopt $sopt $sbrk $copt $nopt $xopt +maxs 2000 $PSftr)>$psfile 2>>$logfile"; $pscmd = "($a2p $abcfile $Fopt $sopt $sbrk $copt $nopt $xopt +maxs 2000 )>$psfile 2>>$logfile"; $pscmd =~ s/ */ /g; &sendLog("ENV{PATH}: \"$ENV{PATH}\"\n") if $V>0; &sendLog("pscmd: \"$pscmd\"\n") if $V>0; &sendLog(`which $a2p`) if $V>0; if ($V>1) { $which = `which $a2p`; &sendLog("$P: $a2p is $which\n") if $V>1; } @psout = &timecmd($pslimit,$a2p,$pscmd); # Was: @psout = `$pscmd`; if ($?) { &sendWeb("pscmd=\"$pscmd\" returned status $?.
\n"); &sendWeb(@psout); &sendLog("pscmd=\"$pscmd\" returned status $?.\n"); &sendLog(@psout); $exitstat = $?; } elsif (@psout && $#psout && $V>0) { &send_LW($#psout . " messages from $a2p:"); &send_LW(@psout); } if ($Fmts{PS}) { &sendLog("Nothing further needed for PS.\n") if $V>2; } if ($Fmts{PDF}) { &sendLog("Convert PS to PDF.\n") if $V>0; $ps2pdf = $Cmd{'ps2pdf'} || 'ps2pdf'; $pdfcmd = "($ps2pdf $psfile $pdffile) >>$logfile 2>&1"; &sendLog("pdffile=\"$pdffile\"\n") if $V>0; if ($V>0) { &sendLog("$P: ps2pdf is $ps2pdf\n"); &sendLog("$P: pdfcmd is $pdfcmd\n"); } @pdfout = `$pdfcmd`; if ($?) { &sendWeb("pdfcmd=\"$pdfcmd\" returned status $?
\n"); &sendLog(@pdfout) if $V>1; $exitstat = $?; } } if ($Fmts{GIF}) { &sendLog("Convert PS to GIF.\n") if $V>0; $ps2gif = $Cmd{'ps2gif'} || 'ps2gif'; $gifcmd = "($ps2gif $hres $vres $psfile) >>$logfile 2>&1"; &sendLog("gifcmd=\"$gifcmd\"\n") if $V>0; if ($V>1) { $which = `which $a2p`; &sendLog("$P: $a2p is $which"); } @gifout = `$gifcmd 2>&1`; if ($?) { &sendWeb("gifcmd=\"$gifcmd\" returned status $?
\n"); &sendLog(@gifout) if $V>1; $exitstat = $?; } $keepgif = 1; &sendWeb("
\n") if $useCenter; &sendWeb("\"$URL\"\n"); &sendWeb("
\n") if $useCenter; } if ($Fmts{PNG}) { &sendLog("Convert PS to PNG.\n") if $V>0; &sendLog(`which ps2png`) if $V>0; # Is there a ps2png visible? &sendLog(`which wpng`) if $V>0; # How about wpng? if (-x ($ps2png = $hst . '-ps2png')) { &sendLog("ps2png='$ps2png'\n") if $V>0; } elsif (-x ($ps2png = './ps2png')) { &sendLog("ps2png='$ps2png'\n") if $V>0; } else { &sendLog("$P: ### Can't find ps2png command.\n") if $V>0; } $pngcmd = "($ps2png $hres $vres $psfile) >>$logfile 2>&1"; &sendLog("pngcmd='$pngcmd'\n") if $V>0; if ($V>1) { $which = `which $a2p`; &sendLog("$P: $a2p is $which"); } @pngout = `$pngcmd`; if ($?) { &sendWeb("pngcmd=\"$pngcmd\" returned status $?
\n"); &sendLog(@pngout) if $V>1; $exitstat = $?; } $keeppng = 1; &sendWeb("
\n") if $useCenter; &sendWeb("\t\"$URL\"\n"); &sendWeb("
\n") if $useCenter; $embedtype .= ' PNG'; $script = $ENV{'SCRIPT_NAME'}; &sendLog("$P: script='$script'\n"); } } if ($Fmts{EPS}) { &sendLog("Convert PS to EPS.\n") if $V>0; if ($V>2) { &sendLog("a2p=\"$a2p\"\n"); &sendLog("abcfile=\"$abcfile\"\n"); &sendLog("sbrk=\"$sbrk\"\n"); &sendLog("Fopt=\"$Fopt\"\n"); &sendLog("copt=\"$copt\"\n"); &sendLog("nopt=\"$nopt\"\n"); &sendLog("xopt=\"$xopt\"\n"); } &sendLog("epsfil0=\"$epsfil0\"\n") if $V>2; &chkdef($a2p,'a2p'); &chkdef($abcfile,'abcfile'); &chkdef($sbrk,'sbrk'); &chkdef($Fopt,'Fopt'); &chkdef($copt,'copt'); &chkdef($nopt,'nopt'); &chkdef($xopt,'xopt'); &chkdef($epsfil0,'epsfil0'); &chkdef($logfile,'logfile'); $epscmd = "$a2p $abcfile $sbrk $Fopt $copt $nopt $xopt +E$epsfil0 2>>$logfile"; &sendLog("epscmd=\"$epscmd\"\n") if $V>0; if ($V>1) { $which = `which $a2p`; &sendLog("$P: $a2p is $which\n") if $V>1; } @epsout = `$epscmd`; if ($?) { &sendWeb("epscmd=\"$epscmd\" returned status $?.
\n"); &sendWeb(@epsout); &sendLog("epscmd=\"$epscmd\" returned status $?.\n"); &sendLog(@epsout); } $exitstat = $?; } #if ($Fmts{XXX}) { # &sendLog("Convert PS to XXX.\n") if $V>0; # $keepeps = 1; # $keepabc = 1; # &sendWeb("XXX format:
\n") if $V>1; # $epscmd = "$a2p $abcfile $sbrk $copt $nopt $xopt +E$epsfil0 2>>$logfile"; # &sendLog("epscmd=\"$epscmd\"\n") if $V>0; # if ($V>1) { # $which = `which $a2p`; # &sendLog("$P: $a2p is $which\n") if $V>1; # } # @epsout = `$epscmd`; # if ($?) { # &sendWeb("epscmd=\"$epscmd\" returned status $?.
\n"); # &sendWeb(@epsout); # &sendLog("epscmd=\"$epscmd\" returned status $?.\n"); # &sendLog(@epsout); # # done($?); # } # &sendLog("Command's output:\n") if $V>1; # &sendLog(@epsout); # &sendLog("Files output:\n") if $V>1; # &sendWeb("
    \n"); # for $line (@epsout) { # &sendLog("Line: $line") if $V>1; # if (($epspth,$title) = ($line =~ /^\[(.*)\]\s*(.*)\s*$/)) { # &sendLog("---: epspth=\"$epspth\" title=\"$title\"\n") if $V>1; # ($epsfil = $epspth) =~ s"^$tmpdir/*""; # &sendWeb("\t
  1. $epsfil $title\n"); # } # } # &sendWeb("
\n"); #} if ($Fmts{MIDI}) { &sendLog("Convert to MIDI.\n") if $V>0; $midicmd = "abc2midi $abcfile -v -o $midifil >>$logfile 2>&1"; &sendLog("midicmd=\"$midicmd\"\n") if $V>0; if ($V>1) { $which = `which abc2midi`; &sendLog("$P: abc2midi is $which\n"); } @midiout = `$midicmd`; if ($?) { &sendWeb("midicmd=\"$midicmd\" returned status $?.
\n"); &sendWeb(@midiout); &sendLog("midicmd=\"$midicmd\" returned status $?.\n"); &sendLog(@midiout); } $exitstat = $?; } if ($Fmts{SVG}) { &sendLog("Convert to SVG '$svgfile'.\n") if $V>0; # $Fopt = $Ffil ? "-F $Ffil" : ''; $Fopt = ''; # Test with no format file $svgcmd = "abcm2ps -v $Fopt $abcfile -O $svgfile >>$logfile 2>&1"; &sendWeb("svgcmd=\"$svgcmd\"
\n") if $V>1; &sendLog("svgcmd=\"$svgcmd\"\n") if $V>0; if ($V>1) { $which = `which abcm2ps`; &sendLog("$P: abcm2ps is $which\n"); } @svgout = `$svgcmd`; if ($?) { &sendWeb("svgcmd=\"$svgcmd\" returned status $?.
\n"); &sendWeb(@svgout); &sendLog("svgcmd=\"$svgcmd\" returned status $?.\n"); &sendLog(@svgout); } @svgfiles = `ls $tmpdir/Tune-$pid*.svg`; for $svgpath (@svgfiles) { if (($svgfile = $svgpath) =~ s"^.*/(.*\.svg)"$1") { &sendLog("SVG file='$svgfile' path='$svgpath'\n") if $V>0; $svgurl = "$tmpurl/$svgfile"; $keepsvg = 1; &sendWeb("
\n") if $useCenter; $embedtype .= ' SVG'; $svglink = &svgLink($svgurl); # What's the best way to embed SVG inside HTML? &sendLog("svglink=\"$svglink\"\n") if $V>0; &sendWeb("\t$svglink\n"); &sendWeb("
\n") if $useCenter; } # $embedtype .= ' SVG'; # $script = $ENV{'SCRIPT_NAME'}; # &sendLog("$P: script='$script'\n"); } $exitstat = $?; } if ($Fmts{PDF} && -f $pdffile) { &sendLog("Embed PDF file \"$pdffile\" pdfurl=\"$pdfurl\"\n") if $V>0; &sendWeb("
\n") if $useCenter; $embedtype .= ' PDF'; $pdflink = &pdfLink($pdfurl); # I've tried several ways of embedding a PDF inside HTML &sendLog("pdflink=\"$pdflink\"\n") if $V>0; &sendWeb("\t$pdflink\n"); &sendWeb("
\n") if $useCenter; } if ($Fmts{HTML}) { # Testing HTML5 output &sendLog("Convert to HTML5.\n") if $V>0; $html5cmd = "abc2html5 $abcfile +v5 -o $h5file >>$logfile 2>&1"; &sendLog("html5cmd=\"$html5cmd\"\n") if $V>0; if ($V>1) { $which = `which abc2html5`; &sendLog("$P: abc2html5 is $which\n"); } $ENV{"V_abc2html5"} = $V; &sendLog("V_abc2html5='" . $ENV{'V_abc2html5'} . "'\n"); @html5out = `$html5cmd`; if ($?) { &sendWeb("html5cmd=\"$html5cmd\" returned status $?.
\n"); &sendWeb(@html5out); &sendLog("html5cmd=\"$html5cmd\" returned status $?.\n"); &sendLog(@html5out); } if (-f $h5file) { # Did we get a HTML file? &send_LW("$P: HTML file \"$h5file\" exists.") if $V>3; &send_LW("$P: Link file \"$h5file\" -> \"$h5last\"") if $V>5; system "/bin/ln -f $h5file $h5last"; # Give it a temporary, consistent name. if (open(H5FILE,$h5file)) { print "\t
\n" if $useCenter; print "\t
\n"; &sendLog("$P: Read $h5file ...") if $V>1; print "\t\t\n"; for $h5line () { &sendLog("==== $h5line") if $V>1; print "\t\t$h5line"; } print "\t\t\n"; print "\t\t
\n"; print "\t
\n" if $useCenter; &sendLog("$P: Close $h5file ...") if $V>1; $embedtype .= ' HTML5'; close H5FILE; } else { &send_LW("$P: ### Can't read \"$h5file\" [$?]"); } } else { &send_LW("### HTML file \"$h5file\" not produced."); } $exitstat = $?; } &sendWeb("
\n") if $V>0; &done($exitstat); sub dumpParams() { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # push @Send, "
[V=$V] Here are our form elements:\n"; @names = $cgi->param(); push @Send, "
\n"; for $n (sort @names) { if (@vals = $cgi->param($n)) { for $v (@vals) {push @Send, "
$n
\"$v\"\n"} } elsif ($v = $cgi->param($n)) { push @Send, "
$n
\"$v\"\n"; } else { push @Send, "
$n
(NO VALUE)\n"; } } push @Send, "
\n"; push @Send, "That's all of them.
\n"; push @Send, "
\n"; } sub LocalSetup { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Figure out where we're running, and try to require a *cgilocal.pm file for # # local settings. The end result of this is to initialize a long list of # # global variables. The return value is the name of the cgilocal file, which # # we usually feed to the 'require' command. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($Vval) = shift; $ENV{PATH} = '/usr/local/bin:/bin:/sbin:/usr/bin:/usr/sbin'; # Tentative PATH push @INC, '.'; # Make sure we can use local executables $testing = 1 unless defined $testing; # Set to 1 while testing unless (defined $V) {$V = 1; $Vsrc = '1:LS'} $Vtest = 1 unless defined $Vtest; umask 0002; # Output files must be group writable $| = 1; # Unbuffered STDOUT $" = ','; # Used in verbose messages $pid = sprintf("%06d",$$); ($P = ($0 || 'tuneget')) =~ s".*/""; # This program's name, minus directories if (($ENV{REMOTE_ADDR} || '0.0.0.0') =~ m/^\s*([\d\.]+)\s*$/) { $RA = $1; } else { $RA = '[not known]'; } &Vset($Vval); local($ss,$mm,$hh,$DD,$MM,$YY) = gmtime(time); # Current date/time $ymd = sprintf("%d-%02d-%02d",1900+$YY,1+$MM,$DD); # CCYY-MM-DD $hms = sprintf("%02d:%02d:%02d",$hh,$mm,$ss); # HH:MM:SS $hostname = `/bin/hostname`; # What does this machine call itself? $hostname =~ s/^\s*([-.\w]*)([\r\s]*)$/$1/; # Strip off domain info ($hst = $1) =~ s/\..*//; # Extract first field of name $cwd = `/bin/pwd`; $hstloc = $hst . "-cgilocal.pm"; $cgiloc = (-f $hstloc) ? $hstloc : 'cgilocal.pm'; return $cgiloc; } sub fromCache { my $F='fromCache'; local($Ndx,$TTL,$URL) = @_; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Look in the abcbot cache for a tune. We return the line count if we find # # the tune, 0 if it wasn't there. The tune will be in the @tune array. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($line,$lines,$mURL,$ndx,$path,$pth1,$pth2,$pth3,$Tgot); @tune = (); # Global copy of current tune ($pth = $URL) =~ s'://'/'; $pth1 .= "$pth:/%$Ndx:$TTL.abc"; # Preferred single-tune cache file name ($pth2 = $pth1) =~ s/^(THE|AN*)//; # Try pth1 without initial article ($pth3 = $pth1) =~ s/(THE|AN*)\.abc$/.abc/; # Try pth1 without trailing article send_LW("$F: pth1='$pth1'") if $V>1; send_LW("$F: pth2='$pth2'") if $V>1; send_LW("$F: pth3='$pth3'") if $V>1; if (-f $pth1) {$path = $pth1} # Does any of these files exist? elsif (-f $pth2) {$path = $pth2} elsif (-f $pth3) {$path = $pth3} else { sendLog("$F: Can't find cache file for X:$Ndx T:$TTL\n") if $V>0; send_LW("$F: pth1='$pth1'") if $V>0; send_LW("$F: pth2='$pth2'") if $V>0; send_LW("$F: pth3='$pth3'") if $V>0; return 0; } sendLog("$F: Found '$path'\n") if $V>1; unless (open(CACHE,$path)) { sendLog("$F: Can't read '$path' [$!]\n") if $V>0; return 0; } sendLog("$F: Using '$path'\n") if $V>1; $ndx = $newNdx + 1; # How does newNdx get set in this case? ($mURL = $URL) =~ s"^http/+"http://"; # Make sure it's really a URL # ($mURL = $URL) =~ s"^cache/+"http://"; # Make sure it's really a URL $Xgot = 1; # Default index number for $line () { $line =~ s/[\r\s]$//; # Trim the lines of white stuff if ($line || @tune) { # Unless it's an initial blank line, push @tune, $line; # add the line to the tune ++$lines; } if ($line =~ /^X:\s*(\d+)/) { $Xgot = int($1); &sendLog("$F: Xgot='$Xgot'\n") if $V>1; } if ($line =~ /^([PT]):\s*(.*)/) { $Tgot = $2; &sendLog("$F: $1: Tgot='$Tgot'\n") if $V>1; } sendLog("$F: Line $lines: $line\n") if $V>1; } close CACHE; if (defined($Tgot)) { sendLog("$F: Added $lines lines to \@tune.\n") if $V>1; &match("C","X:$Xgot",$outNdx,"(H)","T:$Tgot",$mURL); if ($V>1) {for $line (@tune) {sendLog("$F: ## $line\n")}} $Tgood = $Xgood = 1; # Flag the tune as good } else { send_LW("### X:$Ndx T:$TTL not found in cache \"$path\"") if $V>0; } &sendLog("$F: Return $lines.\n") if $V>0; return $lines; } sub keyval { my $F='keyval'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Given a sort key typed in a sel box by a user, convert it into a unique key # # for sorting the tunes. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($x) = @_; local($i,$s,$v); if (($i,$s) = ($x =~ /^(\d+)(.*)$/)) { # Initial number is special $v = sprintf("%8d$s",$i); return $v; } if (defined($i = $KeyCnt{$x})) { # Repeated use of key? $v = sprintf("$x%8d",++$i); # Append the key's count $KeyCnt{$x} = $i; return $v; } $v = $x; # New key; just use it $KeyCnt{$x} = 0; # Note it's been seen return $v; } sub match {my $F='match'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # This generates a "match" line describing one tune match. The result is an # # HTML table entry for the list of matched tunes. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($where,$Xval,$N,$H,$Tval,$mURL) = @_; $mURL =~ s"/\./"/"g; # These tend to slip through; we can fix it here push @matches, "$where$Xval$N$H$Tval$mURL"; } sub pdfLink { my $F='pdfLink'; local($u) = @_; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Return a link to an "embedded" PDF document file. There are several ways of # # doing this in HTML, so we've isolated the task in this routine. This # # routine may change with time, but I'll try to preserve evidence of what's # # been tried so far. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($l) = ''; local($m) = "Try this link if the PDF doesn't show correctly."; local($t) = 'application/pdf'; local($f) = "Your browser doesn't seem to know how to embed a PDF object"; # local($f) = "[PDF failed]"; # $l .= "\n\t$f image."; # $l .= "\n\t$f document."; # $l .= "\n\t
$f object.
"; $l .= "\n\t$f"; $l .= "
$m"; return $l; } sub svgLink { my $F='svgLink'; local($u) = @_; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Return a link to an "embedded" SVG document file. There are several ways of # # doing this in HTML, so we've isolated the task in this routine. This # # routine may change with time, but I'll try to preserve evidence of what's # # been tried so far. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($l) = ''; local($m) = "Try this link if the SVG doesn't show correctly."; local($t) = 'image/svg+xml'; local($f) = "Your browser doesn't seem to know how to embed a SVG"; # local($f) = "[SVG failed]"; # $l .= "\n\t$f image."; # $l .= "\n\t$f document."; # $l .= "\n\t
$f object.
"; $l .= "\n\t$f"; $l .= "
$m"; return $l; } #sub timecmd {my $F='timecmd'; local($limit,$cmd) = @_; ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ## Run a subprocess with a time limit. We collect any stdout data and return # ## it. Info about the timeout is written to stdout, which usually goes to a # ## log file. This replaces commands like: # ## @psout = `$pscmd`; # Convert to PS ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # local($results) = (); # &sendLog("$F: limit=$limit \"$cmd\"\n") if $V>1; # @results = `$cmd`; # return @results; #} sub tuneline { my $F='tuneline'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($line); for (@_) { ($line = $_) =~ s/[\r\n]*$//; &sendLog(">>>>> $line\n") if $V>2; if ($line || @tune) { # Unless it's an initial blank line, push @tune, $line # append line to growing tune } } } sub oneSel { my $F='oneSel'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # } sub sel { my $F='sel'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Sort routine for selection "numbers". What we do is check to see if the two # # keys ($a, $b) start with numbers. If so, we do a numeric sort, with any # # leftover non-digits used to break ties. If either key is nonnumeric, we # # just do an ordinary lexical sort. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local ($ai,$ac, $bi,$bc,$v); if (($ai,$ac) = ($a =~ /^(\d+)(.*)$/)) { if (($bi,$bc) = ($b =~ /^(\d+)(.*)$/)) { # Both start with a number $v = (($ai <=> $bi) || ($ac cmp $bc)); &lsend("$F: $v for '$a' '$b'\n") if $V>1; return $v; } } $v = ($a cmp $b); &lsend("$F: $v for '$a' '$b'\n") if $V>1; return $v; } sub Vset { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Set the global $V to the param or the global variable $Vtest, whichever is # # defined and we've been called from any of several special IP addresses. An # # arg can be included that will be used if $Vtest isn't defined yet. This is # # all an overly-complex way to get the verbose level set to a useful value # # despite all the efforts of a hostile web environment to defeat us. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($Vlvl) = shift || $Vtest || 1; # unless defined $Vtest; if ($RA eq '18.62.1.54') { # trillian.mit.edu if ($V<$Vlvl) {$V = $Vlvl; $Vsrc = "Vlvl=$Vlvl"} $Vwhy = "V=$V from Vval=$Vval Vlvl=$Vlvl Vtest=$Vtest on 18.62.1.54"; } elsif ($RA eq '207.172.223.184') { # jc.tzo.net if ($V<$Vlvl) {$V = $Vlvl; $Vsrc = "Vlvl=$Vlvl"} $Vwhy = "V=$V from Vval=$Vval Vlvl=$Vlvl Vtest=$Vtest on 66.92.73.254"; } elsif ($RA =~ /^192\.168\./) { # My home network if ($V<$Vlvl) {$V = $Vlvl; $Vsrc = "Vlvl=$Vlvl"} $Vwhy = "V=$V from Vval=$Vval Vlvl=$Vlvl Vtest=$Vtest RA=$RA"; } elsif (defined $V) { $Vwhy = "V=$V defined already" unless defined $Vwhy; } else { $V = 1; $Vsrc = $Vwhy = "Vset default"; } return $V; } #sub mimetype { ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # my $f = shift; # my $t = $mimetypes{$f}; # &sendLog("mimetype($f)=\"$t\"\n") if $V>0; # return $t; #} sub abcline { my $F='abcline'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # This routine accepts one or more lines of ABC and possibly does a bit of # # editing to fix common formatting problems. The resulting lines are appended # # to @tunes for later user. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($arg,$line); line: for $arg (@_) { ($line = $arg) =~ s/[\s\r]*$/\n/; # Standardize line endings if (!@tunes && $line eq "\n") { # Initial blank line? &sendLog("Initial blank line dropped.\n") if $V>2 && $line eq "\n"; next line; } if ($HTML) { if ($line =~ s"^<[^>]+>"") { # Strip out HTML tag } elsif ($line =~ s"<[^>]+>\s+$"\n") { # Why was this done? } } if ($line =~ /^\s+$/) { &sendLog("Blank line ignored.\n") if $V>2; next line; } if (($LineWrapKludge && ($line =~ s/:\|\|+[\r\s]+$/:\|\n/)) || ($line =~ /[!*][\r\s]+$/)) { # ABC2Win kludge to undo line wrapping local($prev); ++$LineWrapKludge; if ($prev = pop(@tunes)) { if (length($prev) <= 80) { # Short lines are very likely wrapped if ($prev =~ /^\w:/) { # Don't merge with preceding header lines } elsif ($prev =~ s/([<>"\/])[\r\s]*$/$1$line/) { $line = ''; # Merge with incomplete music line } } if ($prev) { &sendLog("TUNES $prev") if $V>2; push @tunes, $prev; } } } if ($idline && ($line =~ /^K:/)) { &sendLog("TUNES $idline") if $V>2; push @tunes, $idline; # Insert ID line before K: line $idline = ''; # Don't include it again } if ($line =~ /^X:/) { ++$newNdx; $line =~ s/^X:\s*\d*\s*/X: $outNdx\n/; } if ($line ne "\n" || @tunes) { # Omit initial blank lines push @tunes, $line; &sendLog("TUNES $line") if $V>2; &sendLog("Blank line appended.\n") if $V>2 && $line eq "\n"; } else { push @tunes, # [Blank line omitted by $F]\n" if ($P eq 'testget'); &sendLog("$F: Initial blank line omitted.\n") if $V>1; } } } sub endtune { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Here's what need to get done at the end of a tune. It has been accumulated # # in the @tune array, and the $Xgood and $Tgood tell us whether the X: and T: # lines passed their tests. If it's a good tune, we append it to the @tune # array, complete with blank lines as separators, and reinitialize for the # next tune. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if ($Xgood && $Tgood) { $tunelines = int(@tune); &sendLog("EOT: Accepted $tunelines-line tune.\n") if $V>2; &sendLog("X: $X index accepted.\n") if $V>2 && $Xgood; &sendLog("X: $X matches title \"$Trq\"\n") if $V>2 && $Tgood; push @tunes, "\n" if @tunes; # Tune separator &abcline(@tune); } else { # &send_LW("Oops! This file has no tune X:$Xrq T:$Trq") if $V>1; &sendLog("For this tune Xgood=$Xgood Tgood=$Tgood.\n") if $V>1; } @tune = (); $inabc = $insel = 0; $dbgX = $dbgT = undef; &sendLog("\tDone with tune $X; " . int(@tunes) . " lines so far.\n") if $V>1; # if (!$all) { # &send_LW("Oops! This tune has no index $Xrq") unless $Xgood; # &send_LW("Oops! This tune has no title that matches \"$Trq\"") unless $Tgood; # if (($X == $Xrq) && $Trq) { # &send_LW("Oops! X:$X has no title that matches \"$Trq\"\n"); # $xopt = '+x'; # Make sure we send the actual index numbers # } # } $Xgood = $Tgood = 0; } sub hdrline { my $F='hdrline'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Here we do whatever we need to do with an HTTP header line. So far only two # is of any interest to us: the Content-Type and total failure. The return # values are: # -1 Fatal error from server # 0 Header line unrecognized, but unremarkable # 1 Header line precessed # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($line) = @_; local($type,$val); local($val) = 0; if ($line =~ /^HTTP[\/\.\d]*\s+(\d+)\s+(.*)/i) { # HTTP/1.1 404 Not Found $HTTPerrcode = int($1); $HTTPerrmsg = $2; } elsif ($line =~ /^content-type:\s*(.*)/i) { &sendLog("Content-Type: $1\n") if $V>0; $type = lc($1); if ($type =~ m"^text/html;\scharset=(.*)"i) { $HTML = 1; # Bad news! $charset = $1; # Note the charset } elsif ($type =~ m"^text/html\b"i) { $HTML = 1; # Bad news! $charset = undef; } elsif (substr($type,0,5) ne 'text/') { &sendLog("Content-type: \"$1\" dubious.\n") if $V>0; } $val = 1; } elsif ($line =~ /^\n") if $V>1 || $extraDivs; &sendLog("$P: Exit with status $exitstat.\n") if $V>0; close L; &sendWeb("\n"); &sendWeb(""); exit $exitstat; } sub ShowVars { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # &sendWeb("Environment:
\n"); for $k (sort keys %ENV) {$y = $ENV{$k}; &sendWeb("\t
$k
\"$y\"\n")} &sendWeb("
\n"); &sendWeb("Data:
\n"); for $k (sort keys %data) {$y = $data{$k}; &sendWeb("\t
$k
\"$y\"\n")} if ($x = $ENV{PATH_INFO}) {&sendLog("\t
PATH_INFO:
\"$x\"\n");} &sendWeb("
\n"); } sub Uline { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Return the next line from the file U. This is a bit of a kludge because we # # can't rely on the line separators from one line to the next, and no simple # # way has been found to make perl's construct split lines correctly when # # the data uses mixtures of LF, CR, CRLF and LFCR. If anyone finds a more # # elegant way to do this, please let me know. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # local($line,$stat); &sendLog("Uline: Ubuf=\"$Ubuf\"\n") if $V>3; # - - - - - # Note that we insist on finding at least one char after the line terminator. # This is because it's possible for the buffer to end in the middle of a CRLF # or LFCR sequence. [jc 20061109] if ($Ubuf =~ s/^([^\r\n]*?)(\r\n|\n\r|\n|\r)(.)/$3/s) { $Ulin = $1; # The "line" &sendLog("Uline: Ulin=\"$Ulin\"\n") if $V>3; return "$Ulin\n"; } &sendLog("Uline: NO LINE; read more.\n") if $V>3; if (($stat = sysread(U,$Utmp,$Ulen)) > 0) { $Ubuf .= $Utmp; $Ulin = &Uline() || ''; &sendLog("Uline: Ulin=\"$Ulin\"\n") if $V>3; return "$Ulin\n"; } elsif ($Ubuf) { # No input, but data in Ubuf [jc 20061109] $Ulin = $Ubuf; # Return whatever remains $Ubuf = ''; # leaving Ubuf empty return "$Ulin\n"; } else { &send_LW("Uline: Input error [$!].") if ($stat<0 && $V>0); &sendLog("Uline: EOF\n") if $V>3; return undef; } }