diff --git a/bin/.perltidyrc b/bin/.perltidyrc new file mode 100644 index 000000000..c689e069a --- /dev/null +++ b/bin/.perltidyrc @@ -0,0 +1,82 @@ +# Final parameter set for this run. +# See utility 'perltidyrc_dump.pl' for nicer formatting. +--add-newlines +--add-semicolons +--add-whitespace +--backup-file-extension="bak" +--backup-and-modify-in-place +--blank-lines-before-packages=1 +--blank-lines-before-subs=1 +--blanks-before-blocks +--blanks-before-comments +--block-brace-tightness=0 +--block-brace-vertical-tightness=0 +--nobrace-left-and-indent +--brace-tightness=1 +--brace-vertical-tightness=0 +--brace-vertical-tightness-closing=0 +--break-at-old-attribute-breakpoints +--break-at-old-keyword-breakpoints +--break-at-old-logical-breakpoints +--break-at-old-ternary-breakpoints +--nocheck-syntax +--closing-brace-indentation=0 +--closing-paren-indentation=0 +--closing-side-comment-else-flag=0 +--closing-side-comment-interval=6 +--closing-side-comment-maximum-text=20 +--closing-side-comments-balanced +--closing-square-bracket-indentation=0 +--comma-arrow-breakpoints=1 +--continuation-indentation=2 +--nocuddled-else +--delete-old-newlines +--delete-old-whitespace +--delete-semicolons +--fixed-position-side-comment=0 +--format="tidy" +--format-skipping +--fuzzy-line-length +--hanging-side-comments +--nohtml +--html-entities +--html-table-of-contents +--indent-block-comments +--indent-columns=4 +--iterations=1 +--keep-old-blank-lines=1 +--nologfile +--long-block-line-count=8 +--look-for-autoloader +--look-for-selfloader +--maximum-consecutive-blank-lines=1 +--maximum-fields-per-table=0 +--maximum-line-length=80 +--minimum-space-to-comment=4 +--noopening-anonymous-sub-brace-on-new-line +--noopening-brace-on-new-line +--noopening-sub-brace-on-new-line +--nooutdent-labels +--nooutdent-long-comments +--nooutdent-long-quotes +--paren-tightness=1 +--paren-vertical-tightness=0 +--paren-vertical-tightness-closing=0 +--pass-version-line +--perl-syntax-check-flags="-c -T" +--pod2html +--preserve-line-endings +--noquiet +--recombine +--short-concatenation-item-length=8 +--noshow-options +--nospace-for-semicolon +--nospace-terminal-semicolon +--square-bracket-tightness=1 +--square-bracket-vertical-tightness=0 +--square-bracket-vertical-tightness-closing=0 +--static-block-comments +--nostatic-side-comments +--notabs +--trim-qw +--valign diff --git a/bin/alpha_page b/bin/alpha_page index 5656851ac..d6d271c58 100755 --- a/bin/alpha_page +++ b/bin/alpha_page @@ -23,23 +23,32 @@ use strict; -my ($Pgm_Path, $Pgm_Name, $Version); -use vars '$Pgm_Root'; # So we can see it in eval var subs in read_parms +my ( $Pgm_Path, $Pgm_Name, $Version ); +use vars '$Pgm_Root'; # So we can see it in eval var subs in read_parms BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; - ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; - $Pgm_Root = "$Pgm_Path/.."; - eval "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'"; # Use BEGIN eval to keep perl2exe happy + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; + $Pgm_Root = "$Pgm_Path/.."; + eval "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'" + ; # Use BEGIN eval to keep perl2exe happy } - use Getopt::Long; my %parms; -if (!&GetOptions(\%parms, "h", "help", "message=s", "name:s", "pin:i", "service:s") or - @ARGV or $parms{h} or $parms{help} or !$parms{message} or !$parms{service}) { - print<timeout([60]); # Time out after 60 seconds - $ua->env_proxy(); # use proxy if defined - - my $request; - - if ( $srv eq "Arch2way" ) { - $request = POST 'http://www.Arch.com/cgi-bin/wwwtwoway.exe', - [ gw_pin => $pin, - MSSG => $msg, - Q1 => '0', # (No echo) or '1' (echo) -# The remaining fields have been tested and do work, but I am leaving commented out for now until I decide whether or not -# it is worth the effort to make them all config_parms and/or ARGS... -# ATM I am envisioning something like MH seeing a sensor above limit, sends page to 2way and then acts based on response. -# e.g. -message 'No motion detected in house for 2 hours - should all lights be set OFF?' -# -resp_a_string 'Yes' -# -resp_b_string 'No' -# -resp_c_string 'Just Inside Lights' - #resp_route => 'Email', # or 'Pager', (type of response) - #resp_addr => 'account@server.TLD', # address for response - # Note: All below fields require resp_route and resp_addr to be set -# confirm_receipt_str can only be 'confirm_page_delivery', so if confirmation not desired, leave it commented out - #confirm_receipt_str => 'confirm_page_delivery', # optional, (only option) - #resp_a_string => 'A', # Custom response option A - #resp_b_string => 'B', # Custom response option B - #resp_c_string => 'C', # Custom response option C - #resp_d_string => 'D', # Custom response option D - #resp_e_string => 'E', # Custom response option E - #resp_f_string => 'F', # Custom response option F - ]; - } - elsif ( $srv eq "Arch1way" ) { - $request = POST 'http://www.Arch.com/cgi-bin/wwwpage.exe', - [ PIN => $pin, - MSSG => $msg, - ]; - } - elsif ( $srv eq "PageMart" ) { - $request = POST 'http://www2.pagemart.com/cgi-bin/rbox/pglpage-cgi', - [ pin2 => $pin, - PAGELAUNCHERID => '2', - message1 => $msg, - ]; - } - - my $response = $ua->request($request); - - if ( $response ->is_success ) { - print "page sent\n" if $config_parms{debug} eq 'page'; - } - else { - printf "page failed, %s\n", $response->status_line; - } + use LWP::UserAgent; + use HTTP::Request::Common; + my ( $srv, $pin, $msg ) = @_; + + print "send page: ($srv) pin=$pin, $msg\n" + if $config_parms{debug} eq 'page'; + + my $ua = new LWP::UserAgent; + $ua->timeout( [60] ); # Time out after 60 seconds + $ua->env_proxy(); # use proxy if defined + + my $request; + + if ( $srv eq "Arch2way" ) { + $request = POST 'http://www.Arch.com/cgi-bin/wwwtwoway.exe', [ + gw_pin => $pin, + MSSG => $msg, + Q1 => '0', # (No echo) or '1' (echo) + + # The remaining fields have been tested and do work, but I am leaving commented out for now until I decide whether or not + # it is worth the effort to make them all config_parms and/or ARGS... + # ATM I am envisioning something like MH seeing a sensor above limit, sends page to 2way and then acts based on response. + # e.g. -message 'No motion detected in house for 2 hours - should all lights be set OFF?' + # -resp_a_string 'Yes' + # -resp_b_string 'No' + # -resp_c_string 'Just Inside Lights' + #resp_route => 'Email', # or 'Pager', (type of response) + #resp_addr => 'account@server.TLD', # address for response + # Note: All below fields require resp_route and resp_addr to be set + # confirm_receipt_str can only be 'confirm_page_delivery', so if confirmation not desired, leave it commented out + #confirm_receipt_str => 'confirm_page_delivery', # optional, (only option) + #resp_a_string => 'A', # Custom response option A + #resp_b_string => 'B', # Custom response option B + #resp_c_string => 'C', # Custom response option C + #resp_d_string => 'D', # Custom response option D + #resp_e_string => 'E', # Custom response option E + #resp_f_string => 'F', # Custom response option F + ]; + } + elsif ( $srv eq "Arch1way" ) { + $request = POST 'http://www.Arch.com/cgi-bin/wwwpage.exe', + [ + PIN => $pin, + MSSG => $msg, + ]; + } + elsif ( $srv eq "PageMart" ) { + $request = POST 'http://www2.pagemart.com/cgi-bin/rbox/pglpage-cgi', + [ + pin2 => $pin, + PAGELAUNCHERID => '2', + message1 => $msg, + ]; + } + + my $response = $ua->request($request); + + if ( $response->is_success ) { + print "page sent\n" if $config_parms{debug} eq 'page'; + } + else { + printf "page failed, %s\n", $response->status_line; + } } # diff --git a/bin/authors b/bin/authors index 73e8edb69..85c2df26e 100755 --- a/bin/authors +++ b/bin/authors @@ -6,33 +6,35 @@ use strict; # Uses various flakey heuristics to pick out real names. -my @bogus_first = qw(The Tk Bug Web Added Applied Button By Category Change Email Family Fixed Global Henriksen Linux Lan - Memory More On Outlook Preset Radio Random Round Serial Unix Voice Windows Cue Dynamic Festival File Some - ViaVoice SetWindowText Internet My Western Eastern Daylight Restart Call No Peet Rewrote Turtle - Select Solid Edit Telephony Unit Weather Rio Red About Australian Caller Card - Creative Device Digital Direct Evolution Extended External GHz Gentoo Home - How Iridium Misterhouse Motorola Mythtv Password Server Song Charter Ogg European Another Media Moved Video VoIP - Intuitive Package Perl Scalable Southern - ); -my @bogus_last = qw(Homelink House Group Report Programs Aqualink WinTV CallerID Voices Video Faq - Events Address Station Audio Hat MrHouse Clipsal - Remotes Credit Type Inputs Tivo Robotics Codes Commands Celeron Linux Theatre To Flares - GUIs Management Network Info Media Windows Serial Wireless Acid Bay Manager Users - ); +my @bogus_first = + qw(The Tk Bug Web Added Applied Button By Category Change Email Family Fixed Global Henriksen Linux Lan + Memory More On Outlook Preset Radio Random Round Serial Unix Voice Windows Cue Dynamic Festival File Some + ViaVoice SetWindowText Internet My Western Eastern Daylight Restart Call No Peet Rewrote Turtle + Select Solid Edit Telephony Unit Weather Rio Red About Australian Caller Card + Creative Device Digital Direct Evolution Extended External GHz Gentoo Home + How Iridium Misterhouse Motorola Mythtv Password Server Song Charter Ogg European Another Media Moved Video VoIP + Intuitive Package Perl Scalable Southern +); +my @bogus_last = + qw(Homelink House Group Report Programs Aqualink WinTV CallerID Voices Video Faq + Events Address Station Audio Hat MrHouse Clipsal + Remotes Credit Type Inputs Tivo Robotics Codes Commands Celeron Linux Theatre To Flares + GUIs Management Network Info Media Windows Serial Wireless Acid Bay Manager Users +); undef $/; my $f = <>; my %a; -while ($f =~ /([A-Z][a-zA-Z\.\']+) ([A-Z][a-zA-Z\']+)[ \.\,]/gms) { - my ($first, $last) = ($1, $2); - next if $first =~ /^[A-Z]+$/; # Not all uppercase - next if $last =~ /^[A-Z]+$/; # Not all uppercase +while ( $f =~ /([A-Z][a-zA-Z\.\']+) ([A-Z][a-zA-Z\']+)[ \.\,]/gms ) { + my ( $first, $last ) = ( $1, $2 ); + next if $first =~ /^[A-Z]+$/; # Not all uppercase + next if $last =~ /^[A-Z]+$/; # Not all uppercase next if grep /$first/i, @bogus_first; - next if grep /$last/i, @bogus_last; - $first=~ s/\.$//; # Drop the abrev . + next if grep /$last/i, @bogus_last; + $first =~ s/\.$//; # Drop the abrev . $last =~ s/\.$//; - $last =~ s/\'s$//; # Drop the 's suffix - next if $first =~ s/\'s$//; # Ignore Xyz's did... + $last =~ s/\'s$//; # Drop the 's suffix + next if $first =~ s/\'s$//; # Ignore Xyz's did... $a{"$first $last"}++; } @@ -55,10 +57,11 @@ eof my $cnt = 0; $a{'Bruce Winter'} = '-999'; print "\n"; -for my $a (sort {$a{$b} <=> $a{$a} or $a cmp $b} keys %a) { -# print "\t$a was mentioned $a{$a} times\n"; -# print "$a$a{$a}\n"; - print "\n" unless $cnt % 4; +for my $a ( sort { $a{$b} <=> $a{$a} or $a cmp $b } keys %a ) { + + # print "\t$a was mentioned $a{$a} times\n"; + # print "$a$a{$a}\n"; + print "\n" unless $cnt % 4; print "$a$a{$a}\n"; $cnt++; } diff --git a/bin/authors_svn b/bin/authors_svn index af378846e..d3326f431 100644 --- a/bin/authors_svn +++ b/bin/authors_svn @@ -9,49 +9,53 @@ use strict; # which translates to docs/updates.txt. Updates.txt then gets parsed # by mh/bin/authors. -my ($author, $date, $changes); +my ( $author, $date, $changes ); -my %names = (andymc => 'Andrew McLaren', - blecher => 'Joe Blecher', - david_mrhouse => 'David Satterfield', - dnorwood2 => 'David Norwood', - gliming => 'Gregg Liming', - hplato => 'Howard Plato', - 'i-owns-u' => 'Ryan Davies', - jduda => 'Jim Duda', - mattrwilliams => 'Matthew Williams', - petamem => 'PetaMem Research', - pjf02536 => 'Pete Flaherty', - posjodin => 'Peter Sj�din', - tbs007 => 'Tim Spaulding', - troycarpenter => 'Troy Carpenter', - winter => 'Bruce Winter', - zonyl => 'Jason Sharpee', - ); +my %names = ( + andymc => 'Andrew McLaren', + blecher => 'Joe Blecher', + david_mrhouse => 'David Satterfield', + dnorwood2 => 'David Norwood', + gliming => 'Gregg Liming', + hplato => 'Howard Plato', + 'i-owns-u' => 'Ryan Davies', + jduda => 'Jim Duda', + mattrwilliams => 'Matthew Williams', + petamem => 'PetaMem Research', + pjf02536 => 'Pete Flaherty', + posjodin => 'Peter Sj�din', + tbs007 => 'Tim Spaulding', + troycarpenter => 'Troy Carpenter', + winter => 'Bruce Winter', + zonyl => 'Jason Sharpee', +); while (<>) { - # viewvc html format + + # viewvc html format if (/^Modified (.+?) \S+ (\S+) UTC.+ (\S+)$/) { - print "$author :: $date\n - $changes\n" if $author; - $changes = ''; - $author = $3; $date = "$1 $2"; - $author = $names{$author} if $names{$author}; - next; + print "$author :: $date\n - $changes\n" if $author; + $changes = ''; + $author = $3; + $date = "$1 $2"; + $author = $names{$author} if $names{$author}; + next; } - # svn log format + + # svn log format if (/^r\d+ \| (\S+) .+\((.+)\)/) { - print "$author :: $date\n - $changes\n" if $author; - $changes = ''; - $author = $1; $date = $2; - $author = $names{$author} if $names{$author}; - next; + print "$author :: $date\n - $changes\n" if $author; + $changes = ''; + $author = $1; + $date = $2; + $author = $names{$author} if $names{$author}; + next; } next if /^Revision / or /^Original Path/ or /^ *$/ or /^---/; $changes .= $_; } - __END__ ------------------------------------------------------------------------ diff --git a/bin/backup_data b/bin/backup_data index 2bf1f3be3..9282c9bc3 100755 --- a/bin/backup_data +++ b/bin/backup_data @@ -12,21 +12,32 @@ # - 03/03/01 Created. # - The rest of the change log is at the bottom of this file. # -# This free software is licensed under the terms of the GNU public license. +# This free software is licensed under the terms of the GNU public license. # Copyright 1998-2001 Bruce Winter # #--------------------------------------------------------------------------- use strict; -my($Pgm_Path, $Pgm_Name, $Version); +my ( $Pgm_Path, $Pgm_Name, $Version ); + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; } my %parms; use Getopt::Long; -if (!&GetOptions(\%parms, 'h', 'help', 'file=s', 'size=i', 'skip=s', 'age=s', 'no_zip', 'no_date', 'int' ) or - !@ARGV or $parms{h} or $parms{help}) { print<new(); } - my($mday, $month, $year) = (localtime)[3,4,5]; - my $date = sprintf "_%s_%02d_%02d", $year+1900, ++$month, $mday; + my ( $mday, $month, $year ) = (localtime)[ 3, 4, 5 ]; + my $date = sprintf "_%s_%02d_%02d", $year + 1900, ++$month, $mday; - $parms{size} = 100 unless $parms{size}; - $parms{file} = 'backup' unless $parms{file}; - $parms{file} .= $date unless $parms{no_date}; + $parms{size} = 100 unless $parms{size}; + $parms{file} = 'backup' unless $parms{file}; + $parms{file} .= $date unless $parms{no_date}; $parms{file} .= '.tar'; - $parms{file} .= '.gz' unless $parms{no_zip} or (!$parms{int} and $^O eq 'MSWin32'); + $parms{file} .= '.gz' + unless $parms{no_zip} + or ( !$parms{int} and $^O eq 'MSWin32' ); } @@ -94,55 +108,69 @@ sub get_files { print "\nTraversing dir $dir\n"; push @files, &read_dir($dir); } - $msg = "\nRead $counts{dir} directories:\n"; - $msg .= sprintf " - Storing %5.1f MB of data from %4d files\n", $counts{size}/10**6, $counts{file}; - $msg .= sprintf " - Skipped %5.1f MB of data from %4d files with size > $parms{size} KBytes\n", $counts{size_size}/10**6, $counts{count_size}; - $msg .= sprintf " - Skipped %5.1f MB of data from %4d files with name = $parms{skip}\n", $counts{size_skip}/10**6, $counts{count_skip}; - $msg .= sprintf " - Skipped %5.1f MB of data from %4d files with age > $parms{age}\n", $counts{size_age}/10**6, $counts{count_age}; + $msg = "\nRead $counts{dir} directories:\n"; + $msg .= sprintf " - Storing %5.1f MB of data from %4d files\n", + $counts{size} / 10**6, $counts{file}; + $msg .= + sprintf + " - Skipped %5.1f MB of data from %4d files with size > $parms{size} KBytes\n", + $counts{size_size} / 10**6, $counts{count_size}; + $msg .= + sprintf + " - Skipped %5.1f MB of data from %4d files with name = $parms{skip}\n", + $counts{size_skip} / 10**6, $counts{count_skip}; + $msg .= + sprintf + " - Skipped %5.1f MB of data from %4d files with age > $parms{age}\n", + $counts{size_age} / 10**6, $counts{count_age}; print $msg; $log .= $msg; } sub tar_files { - if ($parms{int}) { + if ( $parms{int} ) { print "\nAdding files ...\n"; - $tar->add_data('backup.log', $log); + $tar->add_data( 'backup.log', $log ); $tar->add_files(@files); print "Writing tar file ...\n"; - $tar->write($parms{file}, !$parms{no_zip}); + $tar->write( $parms{file}, !$parms{no_zip} ); } else { - open LIST, ">tar_files.list" or die "Error, could not open tar_files.list: $!\n"; + open LIST, ">tar_files.list" + or die "Error, could not open tar_files.list: $!\n"; print LIST join "\n", @files; close LIST; - # The tar -z gzip does not work with tar on dos :( - my $options = ($parms{no_zip} or $^O eq 'MSWin32') ? '-cf' : 'czf'; -# my $pgm = "tar -T tar_files.list $options $parms{file}"; + + # The tar -z gzip does not work with tar on dos :( + my $options = ( $parms{no_zip} or $^O eq 'MSWin32' ) ? '-cf' : 'czf'; + + # my $pgm = "tar -T tar_files.list $options $parms{file}"; my $pgm = "tar $options $parms{file} -T tar_files.list"; print "\nRunning: $pgm\n"; system $pgm; - if ($^O eq 'MSWin32' and !$parms{no_zip}) { + if ( $^O eq 'MSWin32' and !$parms{no_zip} ) { print "Running: gzip $parms{file}\n"; unlink $parms{file} . '.gz'; system "gzip $parms{file}\n"; $parms{file} .= '.gz'; } } - my ($size, $date) = (stat $parms{file})[7,9]; - printf "\nFile stats: %s %s %s\n\n", $parms{file}, $size, scalar localtime $date ; + my ( $size, $date ) = ( stat $parms{file} )[ 7, 9 ]; + printf "\nFile stats: %s %s %s\n\n", $parms{file}, $size, + scalar localtime $date; } sub read_dir { - my($dir) = @_; + my ($dir) = @_; print " - Reading files in $dir\n"; $counts{dir}++; - opendir(DIR, $dir) or do {print "Error in dir open: $!\n"; return}; + opendir( DIR, $dir ) or do { print "Error in dir open: $!\n"; return }; my @files; - for my $file (sort readdir DIR) { + for my $file ( sort readdir DIR ) { next if $file eq '.' or $file eq '..'; $file = "$dir/$file"; my $size = -s $file; - if ($parms{skip} and $file =~ /$parms{skip}/i) { + if ( $parms{skip} and $file =~ /$parms{skip}/i ) { my $msg = sprintf " - File skipped: %9d %s\n", $size, $file; print $msg; $log .= $msg; @@ -150,11 +178,11 @@ sub read_dir { $counts{size_skip} += $size; next; } - elsif (-d $file) { + elsif ( -d $file ) { push @files, &read_dir($file); next; } - elsif ($size > $parms{size}*1000) { + elsif ( $size > $parms{size} * 1000 ) { my $msg = sprintf " - File too big: %9d %s\n", $size, $file; print $msg; $log .= $msg; @@ -162,10 +190,11 @@ sub read_dir { $counts{size_size} += $size; next; } - elsif ($parms{age} and -M $file > $parms{age}) { -# my $msg = sprintf " - File too old: %9d %s\n", $size, $file; -# print $msg; -# $log .= $msg; + elsif ( $parms{age} and -M $file > $parms{age} ) { + + # my $msg = sprintf " - File too old: %9d %s\n", $size, $file; + # print $msg; + # $log .= $msg; $counts{count_age}++; $counts{size_age} += $size; next; @@ -177,7 +206,6 @@ sub read_dir { close DIR; return @files; } - # # $Log: backup_data,v $ diff --git a/bin/dailystrips b/bin/dailystrips index fd2280e7c..8b30a3d5f 100755 --- a/bin/dailystrips +++ b/bin/dailystrips @@ -7,13 +7,12 @@ # Description: creates an HTML page containing a number of online comics, with an easily exensible framework # Author: Andrew Medico # Created: 23 Nov 2000, 23:33 EST -# Last Modified: 24 Aug 2003, 16:55 +# Last Modified: 24 Aug 2003, 16:55 # Current Revision: 1.0.28-patched # # This copy of dailystrips has been patched by Matthew Williams # to bypass the United Comics Flash based DRM scheme. - # Set up use strict; no strict qw(refs); @@ -24,24 +23,33 @@ use POSIX qw(strftime); use Getopt::Long; use File::Copy; - # Variables -my (%options, $version, $time_today, @localtime_today, @localtime_yesterday, @localtime_tomorrow, $long_date, $short_date, - $short_date_yesterday, $short_date_tomorrow, @get, @strips, %defs, $known_strips, %groups, $known_groups, %classes, $val, - $link_tomorrow, $no_dateparse, @base_dirparts); +my ( + %options, $version, $time_today, + @localtime_today, @localtime_yesterday, @localtime_tomorrow, + $long_date, $short_date, $short_date_yesterday, + $short_date_tomorrow, @get, @strips, + %defs, $known_strips, %groups, + $known_groups, %classes, $val, + $link_tomorrow, $no_dateparse, @base_dirparts +); $version = "1.0.28"; $time_today = time; - # Get options -GetOptions(\%options, 'quiet|q','verbose','output=s','lite','local|l','noindex', - 'archive|a','dailydir|d','stripdir','save|s','nostale','date=s', - 'new|n','defs=s','nopersonal','basedir=s','list','proxy=s', - 'proxyauth=s','noenvproxy','nospaces','useragent=s','version|v','help|h', - 'avantgo', 'random','nosystem','stripnav','nosymlinks','titles=s', - 'retries=s','clean=s','updates=s','noupdates') or exit 1; +GetOptions( + \%options, 'quiet|q', 'verbose', 'output=s', + 'lite', 'local|l', 'noindex', 'archive|a', + 'dailydir|d', 'stripdir', 'save|s', 'nostale', + 'date=s', 'new|n', 'defs=s', 'nopersonal', + 'basedir=s', 'list', 'proxy=s', 'proxyauth=s', + 'noenvproxy', 'nospaces', 'useragent=s', 'version|v', + 'help|h', 'avantgo', 'random', 'nosystem', + 'stripnav', 'nosymlinks', 'titles=s', 'retries=s', + 'clean=s', 'updates=s', 'noupdates' +) or exit 1; # Process options: # Note: Blocks have been ordered so that we only do as much as absolutely @@ -49,9 +57,8 @@ GetOptions(\%options, 'quiet|q','verbose','output=s','lite','local|l','noindex', # specified) # Help and version override anything else -if ($options{'help'}) { - print -"Usage: $0 [OPTION] STRIPS +if ( $options{'help'} ) { + print "Usage: $0 [OPTION] STRIPS STRIPS can be a mix of strip names and group names (group names must be preceeded by an '\@' symbol) 'all' may be used to retrieve all known strips, @@ -109,10 +116,8 @@ Options: -v --version Print version number "; - - if ($^O =~ /Win32/ ) { - print -"Additional Win32 Notes: + if ( $^O =~ /Win32/ ) { + print "Additional Win32 Notes: Windows lacks a number of features and programs found on *NIX, so a number of changes must be made to the program's operation: @@ -121,262 +126,265 @@ changes must be made to the program's operation: 2. Personal and update definition files may or may not work 3. System-wide definition files are not supported "; - } # ' please emacs perlmode + } # ' please emacs perlmode -print "\nBugs and comments to dailystrips\@amedico.dhs.org\n"; + print "\nBugs and comments to dailystrips\@amedico.dhs.org\n"; - exit; + exit; } -if ($options{'version'}) { - print "dailystrips version $version\n"; - exit; +if ( $options{'version'} ) { + print "dailystrips version $version\n"; + exit; } - -if ($options{'date'}) { - eval "require Date::Parse"; - if ($@ ne "") { - die "Error: cannot use --date - Date::Parse not installed\n"; - } else { - import Date::Parse; - } - - unless ($time_today = str2time($options{'date'})) { - die "Error: invalid date specified\n"; - } +if ( $options{'date'} ) { + eval "require Date::Parse"; + if ( $@ ne "" ) { + die "Error: cannot use --date - Date::Parse not installed\n"; + } + else { + import Date::Parse; + } + + unless ( $time_today = str2time( $options{'date'} ) ) { + die "Error: invalid date specified\n"; + } } - # setup time variables (needed during defs parsing) @localtime_today = localtime $time_today; -#long_date = strftime("\%A, \%B \%e, \%Y", @localtime_today); -$long_date = strftime("\%A, \%B \%d, \%Y", @localtime_today); -$short_date = strftime("\%Y.\%m.\%d", @localtime_today); +#long_date = strftime("\%A, \%B \%e, \%Y", @localtime_today); +$long_date = strftime( "\%A, \%B \%d, \%Y", @localtime_today ); -@localtime_yesterday = localtime($time_today - ( 24 * 60 * 60 )); -$short_date_yesterday = strftime("\%Y.\%m.\%d", @localtime_yesterday); -@localtime_tomorrow = localtime ($time_today + 24 * 60 * 60); -$short_date_tomorrow = strftime("\%Y.\%m.\%d", @localtime_tomorrow); +$short_date = strftime( "\%Y.\%m.\%d", @localtime_today ); +@localtime_yesterday = localtime( $time_today - ( 24 * 60 * 60 ) ); +$short_date_yesterday = strftime( "\%Y.\%m.\%d", @localtime_yesterday ); +@localtime_tomorrow = localtime( $time_today + 24 * 60 * 60 ); +$short_date_tomorrow = strftime( "\%Y.\%m.\%d", @localtime_tomorrow ); # Get strip definitions now - info used below -unless ($options{'defs'}) { - if ($^O =~ /Win32/ ) { - $options{'defs'} = 'strips.def'; - } else { - $options{'defs'} = '/usr/share/dailystrips/strips.def'; - } +unless ( $options{'defs'} ) { + if ( $^O =~ /Win32/ ) { + $options{'defs'} = 'strips.def'; + } + else { + $options{'defs'} = '/usr/share/dailystrips/strips.def'; + } } -&get_defs($options{'defs'}); - +&get_defs( $options{'defs'} ); # Load updated defs file -unless (defined $options{'updates'}) -{ - $options{'updates'} = &get_homedir() . "/.dailystrips-updates.def"; +unless ( defined $options{'updates'} ) { + $options{'updates'} = &get_homedir() . "/.dailystrips-updates.def"; } - -unless($options{'noupdates'}) -{ - if (-r $options{'updates'}) { - &get_defs($options{'updates'}); - } +unless ( $options{'noupdates'} ) { + if ( -r $options{'updates'} ) { + &get_defs( $options{'updates'} ); + } } # Get system configurable strip definitions now -unless ($options{'nosystem'}) { - unless (($^O =~ /Win32/) or (! -r '/etc/dailystrips.defs')) { - &get_defs('/etc/dailystrips.defs'); - } +unless ( $options{'nosystem'} ) { + unless ( ( $^O =~ /Win32/ ) or ( !-r '/etc/dailystrips.defs' ) ) { + &get_defs('/etc/dailystrips.defs'); + } } -unless ($options{'nopersonal'}){ - my $personal_defs = &get_homedir() . "/.dailystrips.defs"; - if (-r $personal_defs) { - &get_defs($personal_defs); - } +unless ( $options{'nopersonal'} ) { + my $personal_defs = &get_homedir() . "/.dailystrips.defs"; + if ( -r $personal_defs ) { + &get_defs($personal_defs); + } } -$known_strips = join('|', sort keys %defs); -$known_groups = join('|', sort keys %groups); - -if ($options{'random'}) { - my @known_strips_array = keys %defs; - - push(@get, $known_strips_array[(rand $#known_strips_array)]); - - undef @known_strips_array; -} else { - # Only strips/groups to download remain in @ARGV - # Unconfigured options were already trapped by Getopts with an 'unknown option' - # error - for (@ARGV) { - if (/^($known_strips|all)$/io) { - if ($_ eq "all") { - push (@get, split(/\|/, $known_strips)); - } else { - push(@get, $_); - } - } elsif (/^@/) { - if (/^@($known_groups)$/io) { - push(@get, split(/;/, $groups{$1}{'strips'})); - } else { - die "Error: unknown group: $_\n"; - } - } else { - die "Error: unknown strip: $_\n"; - } - } +$known_strips = join( '|', sort keys %defs ); +$known_groups = join( '|', sort keys %groups ); + +if ( $options{'random'} ) { + my @known_strips_array = keys %defs; + + push( @get, $known_strips_array[ ( rand $#known_strips_array ) ] ); + + undef @known_strips_array; +} +else { + # Only strips/groups to download remain in @ARGV + # Unconfigured options were already trapped by Getopts with an 'unknown option' + # error + for (@ARGV) { + if (/^($known_strips|all)$/io) { + if ( $_ eq "all" ) { + push( @get, split( /\|/, $known_strips ) ); + } + else { + push( @get, $_ ); + } + } + elsif (/^@/) { + if (/^@($known_groups)$/io) { + push( @get, split( /;/, $groups{$1}{'strips'} ) ); + } + else { + die "Error: unknown group: $_\n"; + } + } + else { + die "Error: unknown strip: $_\n"; + } + } } -if ($options{'list'}) { -format = +if ( $options{'list'} ) { + format = @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $_, $val . - print "Available strips:\n"; - for (split(/\|/, $known_strips)) { - $val = $defs{$_}{'name'}; - write; - } - - print "\nAvailable groups:\n"; - for (split(/\|/, $known_groups)) { - $val = $groups{$_}{'desc'}; - write; - } - exit; + print "Available strips:\n"; + for ( split( /\|/, $known_strips ) ) { + $val = $defs{$_}{'name'}; + write; + } + + print "\nAvailable groups:\n"; + for ( split( /\|/, $known_groups ) ) { + $val = $groups{$_}{'desc'}; + write; + } + exit; } -if ($options{'dailydir'} and $options{'stripdir'}) { - die "Error: --dailydir and --stripdir cannot be used together\n"; +if ( $options{'dailydir'} and $options{'stripdir'} ) { + die "Error: --dailydir and --stripdir cannot be used together\n"; } #Set proxy -if ($options{'proxy'}) { - $options{'proxy'} =~ /^(http:\/\/)?(.*?):(.+?)\/?$/i; - unless ($2 and $3) { - die "Error: incorrectly formatted proxy server ('http://server:port' expected)\n"; - } - - $options{'proxy'} = "http://$2:$3"; +if ( $options{'proxy'} ) { + $options{'proxy'} =~ /^(http:\/\/)?(.*?):(.+?)\/?$/i; + unless ( $2 and $3 ) { + die + "Error: incorrectly formatted proxy server ('http://server:port' expected)\n"; + } + + $options{'proxy'} = "http://$2:$3"; } -if (!$options{'noenvproxy'} and !$options{'proxy'} and $ENV{'http_proxy'} ) { - $ENV{'http_proxy'} =~ /(http:\/\/)?(.*?):(.+?)\/?$/i; - unless ($2 and $3) { - die "Error: incorrectly formatted proxy server environment variable\n('http://server:port' expected)\n"; - } - - $options{'proxy'} = "http://$2:$3"; -} +if ( !$options{'noenvproxy'} and !$options{'proxy'} and $ENV{'http_proxy'} ) { + $ENV{'http_proxy'} =~ /(http:\/\/)?(.*?):(.+?)\/?$/i; + unless ( $2 and $3 ) { + die + "Error: incorrectly formatted proxy server environment variable\n('http://server:port' expected)\n"; + } -if ($options{'proxyauth'}) { - unless ($options{'proxyauth'} =~ /^.+?:.+?$/) { - die "Error: incorrectly formatted proxy credentials ('user:pass' expected)\n"; - } + $options{'proxy'} = "http://$2:$3"; } +if ( $options{'proxyauth'} ) { + unless ( $options{'proxyauth'} =~ /^.+?:.+?$/ ) { + die + "Error: incorrectly formatted proxy credentials ('user:pass' expected)\n"; + } +} # Handle/validate other options -if ($options{'clean'} =~ m/\D/) { - die "Error: 'clean' value must be numeric\n"; +if ( $options{'clean'} =~ m/\D/ ) { + die "Error: 'clean' value must be numeric\n"; } -if ($options{'retries'} =~ m/\D/) { - die "Error: 'retries' value must be numeric\n"; +if ( $options{'retries'} =~ m/\D/ ) { + die "Error: 'retries' value must be numeric\n"; } -unless ($options{'retries'}) { - $options{'retries'} = 3; +unless ( $options{'retries'} ) { + $options{'retries'} = 3; } - -if ($options{'basedir'}) { - unless (chdir $options{'basedir'}) { - die "Error: could not change directory to $options{'basedir'}\n"; - } +if ( $options{'basedir'} ) { + unless ( chdir $options{'basedir'} ) { + die "Error: could not change directory to $options{'basedir'}\n"; + } } -if ($options{'titles'}) { - $options{'titles'} .= " "; +if ( $options{'titles'} ) { + $options{'titles'} .= " "; } unless (@get) { - die "Error: no strip specified (--list to list available strips)\n"; + die "Error: no strip specified (--list to list available strips)\n"; } - # verbose overrides quiet -if ($options{'verbose'} and $options{'quiet'}) { - undef $options{'quiet'}; +if ( $options{'verbose'} and $options{'quiet'} ) { + undef $options{'quiet'}; } - # Un-needed vars -undef $known_strips; undef $known_groups; undef $val; - +undef $known_strips; +undef $known_groups; +undef $val; # Go -unless ($options{'quiet'}) { - warn "dailystrips $version starting:\n"; +unless ( $options{'quiet'} ) { + warn "dailystrips $version starting:\n"; } - # Report proxy settings -if ($options{'proxy'}) { - if ($options{'verbose'}) { - warn "Using proxy server $options{'proxy'}\n"; - } - - if ($options{'verbose'} and $options{'proxy_auth'}) { - warn "Using proxy server authentication\n"; - } +if ( $options{'proxy'} ) { + if ( $options{'verbose'} ) { + warn "Using proxy server $options{'proxy'}\n"; + } + + if ( $options{'verbose'} and $options{'proxy_auth'} ) { + warn "Using proxy server authentication\n"; + } } +if ( $options{'local'} ) { + unless ( $options{'quiet'} ) { + warn "Operating in local mode\n"; + } -if ($options{'local'}) { - unless ($options{'quiet'}) { - warn "Operating in local mode\n"; - } - - if ($options{'dailydir'}) { - unless ($options{'quiet'}) { - warn "Operating in daily directory mode\n"; - } - - unless (-d $short_date) { - # any issues with masks and Win32? - unless(mkdir ($short_date, 0755)) { - die "Error: could not create today's directory ($short_date/)\n"; - } - } - } - - unless(open(STDOUT, ">dailystrips-$short_date.html")) { - die "Error: could not open HTML file (dailystrips-$short_date.html) for writing\n"; - } - - unless ($options{'date'}) { - unless ($options{'noindex'}) { - unless ($^O =~ /Win32/) { - unlink("index.html"); - system("ln -s dailystrips-$short_date.html index.html"); - } - } - } - - if ($options{'archive'}) { - - unless (-e "archive.html") { - # Doesn't exist.. create - open(ARCHIVE, ">archive.html") or die "Error: could not create archive.html\n"; - print ARCHIVE -" + if ( $options{'dailydir'} ) { + unless ( $options{'quiet'} ) { + warn "Operating in daily directory mode\n"; + } + + unless ( -d $short_date ) { + + # any issues with masks and Win32? + unless ( mkdir( $short_date, 0755 ) ) { + die + "Error: could not create today's directory ($short_date/)\n"; + } + } + } + + unless ( open( STDOUT, ">dailystrips-$short_date.html" ) ) { + die + "Error: could not open HTML file (dailystrips-$short_date.html) for writing\n"; + } + + unless ( $options{'date'} ) { + unless ( $options{'noindex'} ) { + unless ( $^O =~ /Win32/ ) { + unlink("index.html"); + system("ln -s dailystrips-$short_date.html index.html"); + } + } + } + + if ( $options{'archive'} ) { + + unless ( -e "archive.html" ) { + + # Doesn't exist.. create + open( ARCHIVE, ">archive.html" ) + or die "Error: could not create archive.html\n"; + print ARCHIVE " $options{'titles'}dailystrips archive @@ -399,107 +407,124 @@ if ($options{'local'}) { "; - close(ARCHIVE); - } - - open(ARCHIVE, "; - close(ARCHIVE); - - unless (grep(//, @archive)) { - for (@archive) { - if (s/()/$1\n$long_date<\/a>
/) { - unless(open(ARCHIVE, ">archive.html")) { - die "Error: could not open archive.html for writing\n"; - } - - print ARCHIVE @archive; - close(ARCHIVE); - last; - } - } - } - } - - # Update previous day's file with a "Next Day" link to today's file - if (open(PREVIOUS, "; - close(PREVIOUS); - - # Don't bother if no tag exists in the file (because it has already been updated) - if (grep(//, @previous_page)) { - my $match_count; - - for (@previous_page) { - if (s// | Next day<\/a>/) { - $match_count++; - last if ($match_count == 2); - } - } - - if (open(PREVIOUS, ">dailystrips-$short_date_yesterday.html")) { - print PREVIOUS @previous_page; - close(PREVIOUS); - } else { - warn "Warning: could not open dailystrips-$short_date_yesterday.html for writing\n"; - } - } else { - warn "Warning: did not find any tag in previous day's file to make today's link\n"; - } - } else { - warn "Warning: could not open dailystrips-$short_date_yesterday.html for reading\n"; - } - - -} elsif ($options{'output'}) { - unless ($options{'quiet'}) { - warn "Writing to file $options{'output'}\n"; - } - - unless (open(STDOUT, ">$options{'output'}")) { - die "Error: Could not open output file ($options{'output'}) for writing\n"; - } -} + close(ARCHIVE); + } + + open( ARCHIVE, "; + close(ARCHIVE); + + unless ( grep( //, @archive ) ) { + for (@archive) { + if ( + s/()/$1\n$long_date<\/a>
/ + ) + { + unless ( open( ARCHIVE, ">archive.html" ) ) { + die "Error: could not open archive.html for writing\n"; + } + + print ARCHIVE @archive; + close(ARCHIVE); + last; + } + } + } + } + + # Update previous day's file with a "Next Day" link to today's file + if ( open( PREVIOUS, "; + close(PREVIOUS); + + # Don't bother if no tag exists in the file (because it has already been updated) + if ( grep( //, @previous_page ) ) { + my $match_count; + + for (@previous_page) { + if ( + s// | Next day<\/a>/ + ) + { + $match_count++; + last if ( $match_count == 2 ); + } + } + + if ( open( PREVIOUS, ">dailystrips-$short_date_yesterday.html" ) ) { + print PREVIOUS @previous_page; + close(PREVIOUS); + } + else { + warn + "Warning: could not open dailystrips-$short_date_yesterday.html for writing\n"; + } + } + else { + warn + "Warning: did not find any tag in previous day's file to make today's link\n"; + } + } + else { + warn + "Warning: could not open dailystrips-$short_date_yesterday.html for reading\n"; + } +} +elsif ( $options{'output'} ) { + unless ( $options{'quiet'} ) { + warn "Writing to file $options{'output'}\n"; + } + + unless ( open( STDOUT, ">$options{'output'}" ) ) { + die + "Error: Could not open output file ($options{'output'}) for writing\n"; + } +} # Download image URLs -unless ($options{'quiet'}) { - if ($options{'verbose'}) { - warn "\nRetrieving URLS:\n" - } else { - print STDERR "\nRetrieving URLS..." - } +unless ( $options{'quiet'} ) { + if ( $options{'verbose'} ) { + warn "\nRetrieving URLS:\n"; + } + else { + print STDERR "\nRetrieving URLS..."; + } } for (@get) { - if ($options{'verbose'}) { warn "Retrieving URL for $_\n" } - &get_strip($_); + if ( $options{'verbose'} ) { warn "Retrieving URL for $_\n" } + &get_strip($_); } -unless ($options{'quiet'}) { - if ($options{'verbose'}) { - warn "Retrieving URLS: done\n" - } else { - warn "done\n" - } +unless ( $options{'quiet'} ) { + if ( $options{'verbose'} ) { + warn "Retrieving URLS: done\n"; + } + else { + warn "done\n"; + } } -if (-e "dailystrips-$short_date_tomorrow.html") { - $link_tomorrow = " | Next day" -} else { - $link_tomorrow = "" +if ( -e "dailystrips-$short_date_tomorrow.html" ) { + $link_tomorrow = + " | Next day"; +} +else { + $link_tomorrow = ""; } - # Generate HTML page -if ($options{'lite'}) { - print "$options{'titles'}dailystrips for $long_date

\n"; -} else { - my $topanchor; - if ($options{'stripnav'}) { - $topanchor = "\n\n"; - } +if ( $options{'lite'} ) { + print + "$options{'titles'}dailystrips for $long_date

\n"; +} +else { + my $topanchor; + if ( $options{'stripnav'} ) { + $topanchor = "\n\n"; + } - print -" + print " $options{'titles'}dailystrips for $long_date @@ -513,273 +538,344 @@ $topanchor

< Previous day$link_tomorrow"; - - if ($options{'archive'}) { - print " | Archives"; - } - - print -" > + + if ( $options{'archive'} ) { + print " | Archives"; + } + + print " >

"; - if ($options{'stripnav'}) { - print "Strips:
\n"; - for (@strips) { - my ($strip, $name) = (split(/;/, $_))[0,1]; - print "$name  "; - } - print "\n

"; - } + if ( $options{'stripnav'} ) { + print "Strips:
\n"; + for (@strips) { + my ( $strip, $name ) = ( split( /;/, $_ ) )[ 0, 1 ]; + print "$name  "; + } + print "\n

"; + } - print "\n\n\n"; + print "\n\n
\n"; } - -if ($options{'local'} and !$options{'quiet'}) { - if ($options{'verbose'}) { - warn "\nDownloading strip files:\n" - } else { - print STDERR "Downloading strip files..."; - } +if ( $options{'local'} and !$options{'quiet'} ) { + if ( $options{'verbose'} ) { + warn "\nDownloading strip files:\n"; + } + else { + print STDERR "Downloading strip files..."; + } } for (@strips) { - my ($strip, $name, $homepage, $img_addr, $referer, $prefetch, $artist) = split(/;/, $_); - my ($img_line, $local_name, $local_name_dir, $local_name_file, $local_name_ext, $image, $ext, - $local_name_yesterday, $local_name_yesterday_dir, $local_name_yesterday_file, $local_name_yesterday_ext); - - if ($options{'verbose'} and $options{'local'}) { - warn "Downloading strip file for " . lc((split(/;/, $_))[0]) . "\n"; - } - - if ($img_addr =~ "^unavail") { - if ($options{'verbose'}) { - warn "Error: $strip: could not retrieve URL\n"; - } - - $img_line = "[Error - unable to retrieve URL]"; - } else { - if ($options{'local'}) { - # local mode - download strips - $img_addr =~ /http:\/\/(.*)\/(.*)\.(.*?)([?&].+)?$/; - if (defined $3) { $ext = ".$3" } - - # prepare file names - if ($options{'stripdir'}) { - $local_name_yesterday = "$name/$short_date_yesterday$ext"; - $local_name_yesterday_dir = "$name/"; - $local_name_yesterday_file = $short_date_yesterday; - $local_name_yesterday_ext = $ext; - - $local_name = "$name/$short_date$ext"; - $local_name_dir = "$name/"; - $local_name_file = "$short_date"; - $local_name_ext = "$ext"; - } elsif ($options{'dailydir'}) { - $local_name_yesterday = "$short_date_yesterday/$name-$short_date_yesterday$ext"; - $local_name_yesterday_dir = "$short_date_yesterday/"; - $local_name_yesterday_file = "$name-$short_date_yesterday"; - $local_name_yesterday_ext = "$ext"; - - $local_name = "$short_date/$name-$short_date$ext"; - $local_name_dir = "$short_date/"; - $local_name_file = "$name-$short_date"; - $local_name_ext = "$ext"; - } else { - $local_name_yesterday = "$name-$short_date_yesterday$ext"; - $local_name_yesterday_dir = "./"; - $local_name_yesterday_file = "$name-$short_date_yesterday"; - $local_name_yesterday_ext = "$ext"; - - $local_name = "$name-$short_date$ext"; - $local_name_dir = "./"; - $local_name_file = "$name-$short_date"; - $local_name_ext = "$ext"; - } - - if ($options{'nospaces'}) { - # impossible to tell for sure if previous day's file - # used --nospaces or not, but this should work more - # often - $local_name_yesterday =~ s/\s+//g; - $local_name_yesterday_dir =~ s/\s+//g; - $local_name_yesterday_file =~ s/\s+//g; - - $local_name =~ s/\s+//g; - $local_name_dir =~ s/\s+//g; - $local_name_file =~ s/\s+//g; - } - - # do ops that depend on file name - if ($options{'stripdir'}) { - unless (-d $local_name_dir) { - # any issues with masks and Win32? - mkdir $local_name_dir, 0755; - } - } - - if ($options{'save'} and -e $local_name) { - # already have a suitable local file - skip downloading - if ($options{'avantgo'}) { - $img_line = &make_avantgo_table($local_name, $ext); - } else { - $img_addr = $local_name; - $img_addr =~ s/ /\%20/go; - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } - } else { - # need to download - if ($prefetch) { - if (&http_get($prefetch, $referer) =~ m/^ERROR/) { - warn "Error: $strip: could not download prefetch URL\n"; - $image = "ERROR"; - } else { - $image = &http_get($img_addr, $referer); - } - } else { - $image = &http_get($img_addr, $referer); - #$image = &http_get($img_addr, ""); - } - - if ($image =~ /^ERROR/) { - # couldn't get the image - # FIXME: what to do if a file for the day has already been - # downloaded, but downloading fails when script is run again - # that day? maybe reuse existing file instead of throwing - # error? - if (-e $local_name) { - # an image file for today already exists.. jump to outputting code - #warn "DEBUG: couldn't download strip, but we already have it\n"; - goto HAVE_IMAGE; - } else { - if ($options{'verbose'}) { - warn "Error: $strip: could not download strip\n"; - } - } - - $img_line = "[Error - unable to download image]"; - } else { - HAVE_IMAGE: - # got the image - if ($^O =~ /Win32/) { - # can't do any diff checking on windows (easily, that is - it is doable) - open(IMAGE, ">$local_name"); - binmode(IMAGE); - print IMAGE $image; - close(IMAGE); - - $img_addr = $local_name; - $img_addr =~ s/ /\%20/go; - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } else { - # FIXME: only download to .tmp if earlier file exists - open(IMAGE, ">$local_name.tmp"); - binmode(IMAGE); - print IMAGE $image; - close(IMAGE); - - if (-e $local_name and system("diff \"$local_name\" \"$local_name.tmp\" >/dev/null 2>&1") == 0) { - # already downloaded the same strip earlier today - unlink("$local_name.tmp"); - - if ($options{'avantgo'}) { - $img_line = &make_avantgo_table($local_name, $ext); - } else { - $img_addr = $local_name; - $img_addr =~ s/ /\%20/go; - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } - } elsif (system("diff \"$local_name_yesterday\" \"$local_name.tmp\" >/dev/null 2>&1") == 0) { - # same strip as yesterday - if ($options{'nosymlinks'}) { - system("mv","$local_name.tmp","$local_name"); - } else { - unlink("$local_name.tmp"); - if ($options{'stripdir'} or $options{'dailydir'}) { - system("ln -s \"../$local_name_yesterday\" \"$local_name\" >/dev/null 2>&1"); - } else { - system("ln -s \"$local_name_yesterday\" \"$local_name\" >/dev/null 2>&1"); - } - - } - - if ($options{'nostale'}) { - $img_line = "[Error - new strip not available]"; - } else { - $img_addr = $local_name; - $img_addr =~ s/ /\%20/go; - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } - } else { - # completely new strip - # possible to get here by: - # -downloading a strip for the first time in a day - # -downloading an updated strip that replaces an old one downloaded at - # an earlier time on the same day - system("mv","$local_name.tmp","$local_name"); - - if ($options{'avantgo'}) { - &make_avantgo_files($local_name, $local_name_ext); - $img_line = &make_avantgo_table($local_name, $ext); - } else { - $img_addr = $local_name; - $img_addr =~ s/ /\%20/go; - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } - } - } - } - } - - } else { - # regular mode - just give addresses to strips on their webserver - if ($options{'stripnav'}) { - $img_line = "\"$name\"
Return to top"; - } else { - $img_line = "\"$name\""; - } - } - } - - if ($artist) { - $artist = " by $artist"; - } - - if ($options{'lite'}){ - print -"$name$artist
+ my ( $strip, $name, $homepage, $img_addr, $referer, $prefetch, $artist ) = + split( /;/, $_ ); + my ( + $img_line, $local_name, + $local_name_dir, $local_name_file, + $local_name_ext, $image, + $ext, $local_name_yesterday, + $local_name_yesterday_dir, $local_name_yesterday_file, + $local_name_yesterday_ext + ); + + if ( $options{'verbose'} and $options{'local'} ) { + warn "Downloading strip file for " + . lc( ( split( /;/, $_ ) )[0] ) . "\n"; + } + + if ( $img_addr =~ "^unavail" ) { + if ( $options{'verbose'} ) { + warn "Error: $strip: could not retrieve URL\n"; + } + + $img_line = "[Error - unable to retrieve URL]"; + } + else { + if ( $options{'local'} ) { + + # local mode - download strips + $img_addr =~ /http:\/\/(.*)\/(.*)\.(.*?)([?&].+)?$/; + if ( defined $3 ) { $ext = ".$3" } + + # prepare file names + if ( $options{'stripdir'} ) { + $local_name_yesterday = "$name/$short_date_yesterday$ext"; + $local_name_yesterday_dir = "$name/"; + $local_name_yesterday_file = $short_date_yesterday; + $local_name_yesterday_ext = $ext; + + $local_name = "$name/$short_date$ext"; + $local_name_dir = "$name/"; + $local_name_file = "$short_date"; + $local_name_ext = "$ext"; + } + elsif ( $options{'dailydir'} ) { + $local_name_yesterday = + "$short_date_yesterday/$name-$short_date_yesterday$ext"; + $local_name_yesterday_dir = "$short_date_yesterday/"; + $local_name_yesterday_file = "$name-$short_date_yesterday"; + $local_name_yesterday_ext = "$ext"; + + $local_name = "$short_date/$name-$short_date$ext"; + $local_name_dir = "$short_date/"; + $local_name_file = "$name-$short_date"; + $local_name_ext = "$ext"; + } + else { + $local_name_yesterday = "$name-$short_date_yesterday$ext"; + $local_name_yesterday_dir = "./"; + $local_name_yesterday_file = "$name-$short_date_yesterday"; + $local_name_yesterday_ext = "$ext"; + + $local_name = "$name-$short_date$ext"; + $local_name_dir = "./"; + $local_name_file = "$name-$short_date"; + $local_name_ext = "$ext"; + } + + if ( $options{'nospaces'} ) { + + # impossible to tell for sure if previous day's file + # used --nospaces or not, but this should work more + # often + $local_name_yesterday =~ s/\s+//g; + $local_name_yesterday_dir =~ s/\s+//g; + $local_name_yesterday_file =~ s/\s+//g; + + $local_name =~ s/\s+//g; + $local_name_dir =~ s/\s+//g; + $local_name_file =~ s/\s+//g; + } + + # do ops that depend on file name + if ( $options{'stripdir'} ) { + unless ( -d $local_name_dir ) { + + # any issues with masks and Win32? + mkdir $local_name_dir, 0755; + } + } + + if ( $options{'save'} and -e $local_name ) { + + # already have a suitable local file - skip downloading + if ( $options{'avantgo'} ) { + $img_line = &make_avantgo_table( $local_name, $ext ); + } + else { + $img_addr = $local_name; + $img_addr =~ s/ /\%20/go; + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = "\"$name\""; + } + } + } + else { + # need to download + if ($prefetch) { + if ( &http_get( $prefetch, $referer ) =~ m/^ERROR/ ) { + warn "Error: $strip: could not download prefetch URL\n"; + $image = "ERROR"; + } + else { + $image = &http_get( $img_addr, $referer ); + } + } + else { + $image = &http_get( $img_addr, $referer ); + + #$image = &http_get($img_addr, ""); + } + + if ( $image =~ /^ERROR/ ) { + + # couldn't get the image + # FIXME: what to do if a file for the day has already been + # downloaded, but downloading fails when script is run again + # that day? maybe reuse existing file instead of throwing + # error? + if ( -e $local_name ) { + + # an image file for today already exists.. jump to outputting code + #warn "DEBUG: couldn't download strip, but we already have it\n"; + goto HAVE_IMAGE; + } + else { + if ( $options{'verbose'} ) { + warn "Error: $strip: could not download strip\n"; + } + } + + $img_line = "[Error - unable to download image]"; + } + else { + HAVE_IMAGE: + + # got the image + if ( $^O =~ /Win32/ ) { + + # can't do any diff checking on windows (easily, that is - it is doable) + open( IMAGE, ">$local_name" ); + binmode(IMAGE); + print IMAGE $image; + close(IMAGE); + + $img_addr = $local_name; + $img_addr =~ s/ /\%20/go; + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = "\"$name\""; + } + } + else { + # FIXME: only download to .tmp if earlier file exists + open( IMAGE, ">$local_name.tmp" ); + binmode(IMAGE); + print IMAGE $image; + close(IMAGE); + + if ( + -e $local_name + and system( + "diff \"$local_name\" \"$local_name.tmp\" >/dev/null 2>&1" + ) == 0 + ) + { + # already downloaded the same strip earlier today + unlink("$local_name.tmp"); + + if ( $options{'avantgo'} ) { + $img_line = + &make_avantgo_table( $local_name, $ext ); + } + else { + $img_addr = $local_name; + $img_addr =~ s/ /\%20/go; + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = + "\"$name\""; + } + } + } + elsif ( + system( + "diff \"$local_name_yesterday\" \"$local_name.tmp\" >/dev/null 2>&1" + ) == 0 + ) + { + # same strip as yesterday + if ( $options{'nosymlinks'} ) { + system( "mv", "$local_name.tmp", + "$local_name" ); + } + else { + unlink("$local_name.tmp"); + if ( $options{'stripdir'} + or $options{'dailydir'} ) + { + system( + "ln -s \"../$local_name_yesterday\" \"$local_name\" >/dev/null 2>&1" + ); + } + else { + system( + "ln -s \"$local_name_yesterday\" \"$local_name\" >/dev/null 2>&1" + ); + } + + } + + if ( $options{'nostale'} ) { + $img_line = "[Error - new strip not available]"; + } + else { + $img_addr = $local_name; + $img_addr =~ s/ /\%20/go; + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = + "\"$name\""; + } + } + } + else { + # completely new strip + # possible to get here by: + # -downloading a strip for the first time in a day + # -downloading an updated strip that replaces an old one downloaded at + # an earlier time on the same day + system( "mv", "$local_name.tmp", "$local_name" ); + + if ( $options{'avantgo'} ) { + &make_avantgo_files( $local_name, + $local_name_ext ); + $img_line = + &make_avantgo_table( $local_name, $ext ); + } + else { + $img_addr = $local_name; + $img_addr =~ s/ /\%20/go; + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = + "\"$name\""; + } + } + } + } + } + } + + } + else { + # regular mode - just give addresses to strips on their webserver + if ( $options{'stripnav'} ) { + $img_line = + "\"$name\"
Return to top"; + } + else { + $img_line = "\"$name\""; + } + } + } + + if ($artist) { + $artist = " by $artist"; + } + + if ( $options{'lite'} ) { + print + "$name$artist
$img_line

"; - } else { - my $stripanchor; - if ($options{'stripnav'}) { - $stripanchor = ""; - } - - print -" + } + else { + my $stripanchor; + if ( $options{'stripnav'} ) { + $stripanchor = ""; + } + + print " @@ -791,30 +887,29 @@ $img_line
 "; - } + } } -if ($options{'local'} and !$options{'quiet'}) { - if ($options{'verbose'}) { - warn "Downloading strip files: done\n" - } else { - warn "done\n" - } +if ( $options{'local'} and !$options{'quiet'} ) { + if ( $options{'verbose'} ) { + warn "Downloading strip files: done\n"; + } + else { + warn "done\n"; + } } -unless ($options{'lite'}) { - print -"
$stripanchor$name$artist
+unless ( $options{'lite'} ) { + print "

< Previous day$link_tomorrow"; - if ($options{'archive'}) { - print " | Archives"; - } - - print -" > + if ( $options{'archive'} ) { + print " | Archives"; + } + + print " >

Generated by dailystrips $version @@ -825,718 +920,771 @@ unless ($options{'lite'}) { "; } -if (!$options{'date'} and !$options{'noindex'} and $^O =~ /Win32/) { - # no symlinks on windows.. just make a copy of the file - close(STDOUT); - copy("dailystrips-$short_date.html","index.html"); -} +if ( !$options{'date'} and !$options{'noindex'} and $^O =~ /Win32/ ) { + # no symlinks on windows.. just make a copy of the file + close(STDOUT); + copy( "dailystrips-$short_date.html", "index.html" ); +} # Clean out old files, if requested -if ($options{'clean'}) { - unless ($options{'quiet'}) { - print STDERR "Cleaning files older than $options{'clean'} days..."; - } - - unless (system("perl -S dailystrips-clean --quiet $options{'clean'}")) { - unless ($options{'quiet'}) { - print STDERR "done\n"; - } - } - else { - warn "failed\nWarning: could not run dailystrips-clean script\n"; - } - - +if ( $options{'clean'} ) { + unless ( $options{'quiet'} ) { + print STDERR "Cleaning files older than $options{'clean'} days..."; + } + + unless ( system("perl -S dailystrips-clean --quiet $options{'clean'}") ) { + unless ( $options{'quiet'} ) { + print STDERR "done\n"; + } + } + else { + warn "failed\nWarning: could not run dailystrips-clean script\n"; + } + } sub http_get { - my ($url, $referer) = @_; - my ($request, $response, $status); - - # default value - #unless ($retries) { - # $retries = 3; - #} - - if ($referer eq "") {$referer = $url;} - - my $headers = new HTTP::Headers; - $headers->proxy_authorization_basic(split(/:/, $options{'proxyauth'})); - $headers->referer($referer); - - my $ua = LWP::UserAgent->new; - $ua->agent($options{'useragent'}); - $ua->proxy('http', $options{'proxy'}); - - for (1 .. $options{'retries'}) { - # main request - $request = HTTP::Request->new('GET', $url, $headers); - $response = $ua->request($request); - ($status = $response->status_line()) =~ s/^(\d+)/$1:/; - - if ($response->is_error()) { - if ($options{'verbose'}) { - warn "Warning: could not download $url: $status (attempt $_ of $options{'retries'})\n"; - } - } else { - return $response->content; - } - } - - # if we get here, URL retrieval completely failed - warn "Warning: failed to download $url\n"; - return "ERROR: $status"; + my ( $url, $referer ) = @_; + my ( $request, $response, $status ); + + # default value + #unless ($retries) { + # $retries = 3; + #} + + if ( $referer eq "" ) { $referer = $url; } + + my $headers = new HTTP::Headers; + $headers->proxy_authorization_basic( split( /:/, $options{'proxyauth'} ) ); + $headers->referer($referer); + + my $ua = LWP::UserAgent->new; + $ua->agent( $options{'useragent'} ); + $ua->proxy( 'http', $options{'proxy'} ); + + for ( 1 .. $options{'retries'} ) { + + # main request + $request = HTTP::Request->new( 'GET', $url, $headers ); + $response = $ua->request($request); + ( $status = $response->status_line() ) =~ s/^(\d+)/$1:/; + + if ( $response->is_error() ) { + if ( $options{'verbose'} ) { + warn + "Warning: could not download $url: $status (attempt $_ of $options{'retries'})\n"; + } + } + else { + return $response->content; + } + } + + # if we get here, URL retrieval completely failed + warn "Warning: failed to download $url\n"; + return "ERROR: $status"; } sub get_strip { - my ($strip) = @_; - my ($page, $addr); - - if ($options{'date'} and $defs{$strip}{'provides'} eq "latest") { - if ($options{'verbose'}) { - warn "Warning: strip $strip not compatible with --date, skipping\n"; - } - - next; - } - - if ($defs{$strip}{'type'} eq "search") { - $page = &http_get($defs{$strip}{'searchpage'}); - - if ($page =~ /^ERROR/) { - if ($options{'verbose'}) { - warn "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-server"; - } else { - $page =~ /$defs{$strip}{'searchpattern'}/si; - my @regexmatch; - for (1..9) { - $regexmatch[$_] = ${$_}; - #warn "regex match #$_: ${$_}\n"; - } - - unless (${$defs{$strip}{'matchpart'}}) { - if ($options{'verbose'}) { - warn "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-nomatch"; - } else { - my $match = ${$defs{$strip}{'matchpart'}}; - - if ($defs{$strip}{'imageurl'}) { - $addr = $defs{$strip}{'imageurl'}; - $addr =~ s/\$match_(\d)/$regexmatch[$1]/ge; - $addr =~ s/\$match/$match/ge; - } else { - $addr = $defs{$strip}{'baseurl'} . $match . $defs{$strip}{'urlsuffix'}; - } - } - } - - } elsif ($defs{$strip}{'type'} eq "generate") { - $addr = $defs{$strip}{'baseurl'} . $defs{$strip}{'imageurl'}; - } elsif ($defs{$strip}{'type'} eq "flashdrm") { - $page = &http_get($defs{$strip}{'searchpage'}); - - if ($page =~ /^ERROR/) { - if ($options{'verbose'}) { - warn "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-server"; - } else { - $page =~ /$defs{$strip}{'searchpattern'}/si; - my @regexmatch; - for (1..9) { - $regexmatch[$_] = ${$_}; - #warn "regex match #$_: ${$_}\n"; - } - - unless ($regexmatch[1]) { - warn "didn't match\n"; - if ($options{'verbose'}) { - warn "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-nomatch"; - } else { - $page = &http_get($defs{$strip}{'drmurl'}); - if ($page =~ /^ERROR/) { - warn "Error: $strip: can't download drmurl\n"; - $addr = "unavail-server"; - } else { - my ($drmkey) = $page =~ m!(.+)!s; - if ($drmkey eq '') { - warn "Error: $strip: unable to locate drmkey\n"; - } else { - my $match = ${$defs{$strip}{'matchpart'}}; - - if ($defs{$strip}{'imageurl'}) { - $addr = $defs{$strip}{'imageurl'}; - $addr =~ s/\$match_(\d)/$regexmatch[$1]/ge; - $addr =~ s/\$match/$match/ge; - $addr =~ s/\$drmkey/$drmkey/ge; - } else { - warn "Error: $strip: You must supply an imageurl\n"; - } - } - } - } - } - } elsif ($defs{$strip}{'type'} eq "doublesearch") { - $page = &http_get($defs{$strip}{'searchpage'}); - - if ($page =~ /^ERROR/) { - if ($options{'verbose'}) { - warn "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-server"; - } else { - $page =~ /$defs{$strip}{'searchpattern'}/si; - my @regexmatch; - for (1..9) { - $regexmatch[$_] = ${$_}; - #warn "regex match #$_: ${$_}\n"; - } - - unless ($regexmatch[2]) { - warn "didn't match\n"; - if ($options{'verbose'}) { - warn "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; - } - - $addr = "unavail-nomatch"; - } else { - $addr=$defs{$strip}{'baseurl'}.$regexmatch[1].$regexmatch[2]; - $addr =~ s/%3D/=/g; - $addr =~ s/%26/&/g; - #warn "downloading $addr\n"; - $page = &http_get($addr); - if ($page =~ /^ERROR/) { - warn "Error: $strip: can't download drmurl\n"; - $addr = "unavail-server"; - } else { - $regexmatch[1]=''; - $page =~ /$defs{$strip}{'searchpattern2'}/si; - for (1..9) { - $regexmatch[$_] = ${$_}; - #warn "regex match #$_: ${$_}\n"; - } - unless ($regexmatch[1]) { - warn "didn't match 2\n"; - if ($options{'verbose'}) { - warn "Error: $strip: searchpattern $defs{$strip}{'searchpattern2'} did not match anything in searchpage $defs{$strip}{'baseurl'}.$regexmatch[1].$regexmatch[2]\n"; - } - } else { - $addr=$regexmatch[1]; - } - } - } - } - } elsif ($defs{$strip}{'type'} eq "search2pages") { - # Search pattern for when it takes two pages to get to the image file - # Pull down the first page - $page = &http_get($defs{$strip}{'searchpage'}); - if ($page =~ /^ERROR/) { - if ($options{'verbose'}) { - warn "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; - } - $addr = "unavail-server"; - } else { # And dig through it for the URL for the second page - $page =~ /$defs{$strip}{'searchpattern'}/si; - my @regexmatch; - for (1..9) { $regexmatch[$_] = ${$_}; - } - unless ($regexmatch[1]) { - warn "didn't match\n"; - if ($options{'verbose'}) { - warn "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; - } - $addr = "unavail-nomatch"; - } else { - # Now go to the second page, and dig through it for the image URL - $addr = $defs{$strip}{'baseurl'} . $regexmatch[1]; - $page = &http_get($addr); - if ($page =~ /^ERROR/) { - warn "Error: $strip: can't download 2nd page\n"; - $addr = "unavail-server"; - } else { - # find the information in the second page - my ($searchkey) = $page =~ /$defs{$strip}{'searchpattern2'}/; - if ($searchkey eq '') { - warn "Error: $strip: unable to locate searchkey2\n"; - } else { - # and build the image url from it and the base. - if ($defs{$strip}{'baseurl'}) { - $addr = $defs{$strip}{'baseurl'} . $searchkey; - } else { - warn "Error: $strip: You must supply a baseurl\n"; - } - } - } - } - } - } - - unless ($addr =~ /^(http:\/\/|unavail)/io) { $addr = "http://" . $addr } - - push(@strips,"$strip;$defs{$strip}{'name'};$defs{$strip}{'homepage'};$addr;$defs{$strip}{'referer'};$defs{$strip}{'prefetch'};$defs{$strip}{'artist'}"); + my ($strip) = @_; + my ( $page, $addr ); + + if ( $options{'date'} and $defs{$strip}{'provides'} eq "latest" ) { + if ( $options{'verbose'} ) { + warn "Warning: strip $strip not compatible with --date, skipping\n"; + } + + next; + } + + if ( $defs{$strip}{'type'} eq "search" ) { + $page = &http_get( $defs{$strip}{'searchpage'} ); + + if ( $page =~ /^ERROR/ ) { + if ( $options{'verbose'} ) { + warn + "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-server"; + } + else { + $page =~ /$defs{$strip}{'searchpattern'}/si; + my @regexmatch; + for ( 1 .. 9 ) { + $regexmatch[$_] = ${$_}; + + #warn "regex match #$_: ${$_}\n"; + } + + unless ( ${ $defs{$strip}{'matchpart'} } ) { + if ( $options{'verbose'} ) { + warn + "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-nomatch"; + } + else { + my $match = ${ $defs{$strip}{'matchpart'} }; + + if ( $defs{$strip}{'imageurl'} ) { + $addr = $defs{$strip}{'imageurl'}; + $addr =~ s/\$match_(\d)/$regexmatch[$1]/ge; + $addr =~ s/\$match/$match/ge; + } + else { + $addr = + $defs{$strip}{'baseurl'} + . $match + . $defs{$strip}{'urlsuffix'}; + } + } + } + + } + elsif ( $defs{$strip}{'type'} eq "generate" ) { + $addr = $defs{$strip}{'baseurl'} . $defs{$strip}{'imageurl'}; + } + elsif ( $defs{$strip}{'type'} eq "flashdrm" ) { + $page = &http_get( $defs{$strip}{'searchpage'} ); + + if ( $page =~ /^ERROR/ ) { + if ( $options{'verbose'} ) { + warn + "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-server"; + } + else { + $page =~ /$defs{$strip}{'searchpattern'}/si; + my @regexmatch; + for ( 1 .. 9 ) { + $regexmatch[$_] = ${$_}; + + #warn "regex match #$_: ${$_}\n"; + } + + unless ( $regexmatch[1] ) { + warn "didn't match\n"; + if ( $options{'verbose'} ) { + warn + "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-nomatch"; + } + else { + $page = &http_get( $defs{$strip}{'drmurl'} ); + if ( $page =~ /^ERROR/ ) { + warn "Error: $strip: can't download drmurl\n"; + $addr = "unavail-server"; + } + else { + my ($drmkey) = $page =~ m!(.+)!s; + if ( $drmkey eq '' ) { + warn "Error: $strip: unable to locate drmkey\n"; + } + else { + my $match = ${ $defs{$strip}{'matchpart'} }; + + if ( $defs{$strip}{'imageurl'} ) { + $addr = $defs{$strip}{'imageurl'}; + $addr =~ s/\$match_(\d)/$regexmatch[$1]/ge; + $addr =~ s/\$match/$match/ge; + $addr =~ s/\$drmkey/$drmkey/ge; + } + else { + warn "Error: $strip: You must supply an imageurl\n"; + } + } + } + } + } + } + elsif ( $defs{$strip}{'type'} eq "doublesearch" ) { + $page = &http_get( $defs{$strip}{'searchpage'} ); + + if ( $page =~ /^ERROR/ ) { + if ( $options{'verbose'} ) { + warn + "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-server"; + } + else { + $page =~ /$defs{$strip}{'searchpattern'}/si; + my @regexmatch; + for ( 1 .. 9 ) { + $regexmatch[$_] = ${$_}; + + #warn "regex match #$_: ${$_}\n"; + } + + unless ( $regexmatch[2] ) { + warn "didn't match\n"; + if ( $options{'verbose'} ) { + warn + "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; + } + + $addr = "unavail-nomatch"; + } + else { + $addr = + $defs{$strip}{'baseurl'} . $regexmatch[1] . $regexmatch[2]; + $addr =~ s/%3D/=/g; + $addr =~ s/%26/&/g; + + #warn "downloading $addr\n"; + $page = &http_get($addr); + if ( $page =~ /^ERROR/ ) { + warn "Error: $strip: can't download drmurl\n"; + $addr = "unavail-server"; + } + else { + $regexmatch[1] = ''; + $page =~ /$defs{$strip}{'searchpattern2'}/si; + for ( 1 .. 9 ) { + $regexmatch[$_] = ${$_}; + + #warn "regex match #$_: ${$_}\n"; + } + unless ( $regexmatch[1] ) { + warn "didn't match 2\n"; + if ( $options{'verbose'} ) { + warn + "Error: $strip: searchpattern $defs{$strip}{'searchpattern2'} did not match anything in searchpage $defs{$strip}{'baseurl'}.$regexmatch[1].$regexmatch[2]\n"; + } + } + else { + $addr = $regexmatch[1]; + } + } + } + } + } + elsif ( $defs{$strip}{'type'} eq "search2pages" ) { + + # Search pattern for when it takes two pages to get to the image file + # Pull down the first page + $page = &http_get( $defs{$strip}{'searchpage'} ); + if ( $page =~ /^ERROR/ ) { + if ( $options{'verbose'} ) { + warn + "Error: $strip: could not download searchpage $defs{$strip}{'searchpage'}\n"; + } + $addr = "unavail-server"; + } + else { # And dig through it for the URL for the second page + $page =~ /$defs{$strip}{'searchpattern'}/si; + my @regexmatch; + for ( 1 .. 9 ) { + $regexmatch[$_] = ${$_}; + } + unless ( $regexmatch[1] ) { + warn "didn't match\n"; + if ( $options{'verbose'} ) { + warn + "Error: $strip: searchpattern $defs{$strip}{'searchpattern'} did not match anything in searchpage $defs{$strip}{'searchpage'}\n"; + } + $addr = "unavail-nomatch"; + } + else { + # Now go to the second page, and dig through it for the image URL + $addr = $defs{$strip}{'baseurl'} . $regexmatch[1]; + $page = &http_get($addr); + if ( $page =~ /^ERROR/ ) { + warn "Error: $strip: can't download 2nd page\n"; + $addr = "unavail-server"; + } + else { + # find the information in the second page + my ($searchkey) = + $page =~ /$defs{$strip}{'searchpattern2'}/; + if ( $searchkey eq '' ) { + warn "Error: $strip: unable to locate searchkey2\n"; + } + else { + # and build the image url from it and the base. + if ( $defs{$strip}{'baseurl'} ) { + $addr = $defs{$strip}{'baseurl'} . $searchkey; + } + else { + warn "Error: $strip: You must supply a baseurl\n"; + } + } + } + } + } + } + + unless ( $addr =~ /^(http:\/\/|unavail)/io ) { $addr = "http://" . $addr } + + push( @strips, + "$strip;$defs{$strip}{'name'};$defs{$strip}{'homepage'};$addr;$defs{$strip}{'referer'};$defs{$strip}{'prefetch'};$defs{$strip}{'artist'}" + ); } sub get_defs { - my $defs_file = shift; - my ($strip, $class, $sectype, $group); - my $line; - - unless(open(DEFS, "<$defs_file")) { - die "Error: could not open strip definitions file $defs_file\n"; - } - - my @defs_file = ; - close(DEFS); - - if ($options{'verbose'}) { - warn "Loading definitions from file $defs_file\n"; - } - - for (@defs_file) { - $line++; - - chomp; - s/#(.*)//; s/^\s*//; s/\s*$//; - - next if $_ eq ""; - - if (!$sectype) { - if (/^strip\s+(\w+)$/i) - { - if (defined ($defs{$1})) - { - undef $defs{$1}; - } - - $strip = $1; - $sectype = "strip"; - } - elsif (/^class\s+(.*)$/i) - { - if (defined ($classes{$1})) - { - undef $classes{$1}; - } - - $class = $1; - $sectype = "class"; - } - elsif (/^group\s+(.*)$/i) - { - if (defined ($groups{$1})) - { - undef $groups{$1}; - } - - $group = $1; - $sectype = "group"; - } - elsif (/^(.*)/) - { - die "Error: Unknown keyword '$1' at $defs_file line $line\n"; - } - } - elsif (/^end$/i) - { - if ($sectype eq "class") - { - undef $class - } - elsif ($sectype eq "strip") - { - if ($defs{$strip}{'useclass'}) { - my $using_class = $defs{$strip}{'useclass'}; - - # import vars from class - for (qw(homepage searchpage searchpattern baseurl imageurl urlsuffix referer prefetch artist drmurl searchpattern2)) { - if ($classes{$using_class}{$_} and !$defs{$strip}{$_}) { - my $classvar = $classes{$using_class}{$_}; - $classvar =~ s/(\$[0-9])/$defs{$strip}{$1}/g; - $classvar =~ s/\$strip/$strip/g; - $defs{$strip}{$_} = $classvar; - } - } - - for (qw(type matchpart provides)) { - if ($classes{$using_class}{$_} and !$defs{$strip}{$_}) { - $defs{$strip}{$_} = $classes{$using_class}{$_}; - } - } - } - - #substitute auto vars for real vals here/set defaults - unless ($defs{$strip}{'searchpage'}) {$defs{$strip}{'searchpage'} = $defs{$strip}{'homepage'}} - unless ($defs{$strip}{'referer'}) { - if ($defs{$strip}{'searchpage'}) { - $defs{$strip}{'referer'} = $defs{$strip}{'searchpage'} - } else { - $defs{$strip}{'referer'} = $defs{$strip}{'homepage'} - } - } - - #other vars in definition - for (qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer prefetch)) { - if ($defs{$strip}{$_}) { - $defs{$strip}{$_} =~ s/\$(name|homepage|searchpage|searchpattern|imageurl|baseurl|referer|prefetch)/$defs{$strip}{$1}/g; - } - } - - #dates - for (qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer prefetch)) { - if ($defs{$strip}{$_}) { - $defs{$strip}{$_} =~ s/(\%(-?)[a-zA-Z])/strftime("$1", @localtime_today)/ge; - } - } - - # stuff - for (qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer)) { - if ($defs{$strip}{$_}) { - $defs{$strip}{$_} =~ s//&my_eval($1)/ge; - } - } - - #sanity check vars - for (qw(name homepage type)) { - unless ($defs{$strip}{$_}) { - die "Error: strip $strip has no '$_' value\n"; - } - } - - for (qw(homepage searchpage baseurl imageurl)){ - if ($defs{$strip}{$_} and $defs{$strip}{$_} !~ /^http:\/\//io) { - die "Error: strip $strip has invalid $_\n" - } - } - - if ($defs{$strip}{'type'} eq "search") { - unless ($defs{$strip}{'searchpattern'}) { - die "Error: strip $strip has no 'searchpattern' value in $defs_file\n"; - } - - unless ($defs{$strip}{'searchpattern'} =~ /\(.+\)/) { - die "Error: strip $strip has no parentheses in searchpattern\n"; - } - - unless ($defs{$strip}{'matchpart'}) { - #die "Error: strip $strip has no 'matchpart' value in $defs_file\n"; - $defs{$strip}{'matchpart'} = 1; - } - - if ($defs{$strip}{'imageurl'} and ($defs{$strip}{'baseurl'} or $defs{$strip}{'urlsuffix'})) { - die "Error: strip $strip: cannot use both 'imageurl' at the same time as 'baseurl'\nor 'urlsuffix'\n"; - } - } elsif ($defs{$strip}{'type'} eq "generate") { - unless ($defs{$strip}{'imageurl'}) { - die "Error: strip $strip has no 'imageurl' value in $defs_file\n"; - } - } - - unless ($defs{$strip}{'provides'}) { - die "Error: strip $strip has no 'provides' value in $defs_file\n"; - } - - #debugger - #foreach my $strip (keys %defs) { - # foreach my $key (qw(homepage searchpage searchpattern imageurl baseurl referer prefetch)) { - # warn "DEBUG: $strip:$key=$defs{$strip}{$key}\n"; - # } - # #warn "DEBUG: $strip:name=$defs{$strip}{'name'}\n"; - #} - - undef $strip; - } - elsif ($sectype eq "group") - { - chop $groups{$group}{'strips'}; - - unless ($groups{$group}{'desc'}) { - $groups{$group}{'desc'} = "[No description]"; - } - - undef $group; - } - - undef $sectype; - } - elsif ($sectype eq "class") { - if (/^homepage\s+(.+)$/i) { - $classes{$class}{'homepage'} = $1; - } - elsif (/^type\s+(.+)$/i) - { - unless ($1 =~ /^(search|generate|flashdrm)$/io) { - die "Error: invalid type at $defs_file line $line\n"; - } - - $classes{$class}{'type'} = $1; - } - elsif (/^searchpage\s+(.+)$/i) - { - $classes{$class}{'searchpage'} = $1; - } - elsif (/^searchpattern\s+(.+)$/i) - { - $classes{$class}{'searchpattern'} = $1; - } - elsif (/^matchpart\s+(.+)$/i) - { - unless ($1 =~ /^(\d)$/) { - die "Error: invalid 'matchpart' at $defs_file line $line\n"; - } - - $classes{$class}{'matchpart'} = $1; - } - elsif (/^baseurl\s+(.+)$/i) - { - $classes{$class}{'baseurl'} = $1; - } - elsif (/^urlsuffix\s+(.+)$/i) - { - $classes{$class}{'urlsufix'} = $1; - } - elsif (/^imageurl\s+(.+)$/i) - { - $classes{$class}{'imageurl'} = $1; - } - elsif (/^referer\s+(.+)$/i) - { - $classes{$class}{'referer'} = $1; - } - elsif (/^prefetch\s+(.+)$/i) - { - $classes{$class}{'prefetch'} = $1; - } - elsif (/^provides\s+(.+)$/i) - { - unless ($1 =~ /^(any|latest)$/i) { - die "Error: invalid 'provides' at $defs_file line $line\n"; - } - - $classes{$class}{'provides'} = $1; - } - elsif (/^artist\s+(.+)$/i) - { - $classes{$class}{'artist'} = $1; - } - elsif (/^drmurl\s+(.+)$/i) - { - $classes{$class}{'drmurl'} = $1; - } - elsif (/^(.+)\s+?/) - { - die "Unknown keyword '$1' at $defs_file line $line\n"; - } - } - elsif ($sectype eq "strip") { - if (/^name\s+(.+)$/i) - { - $defs{$strip}{'name'} = $1; - } - elsif (/^useclass\s+(.+)$/i) - { - unless (defined $classes{$1}) { - die "Error: strip $strip references invalid class $1 at $defs_file line $line\n"; - } - - $defs{$strip}{'useclass'} = $1; - } - elsif (/^homepage\s+(.+)$/i) { - $defs{$strip}{'homepage'} = $1; - } - elsif (/^type\s+(.+)$/i) - { - unless ($1 =~ /^(search|generate|flashdrm|search2pages|doublesearch)$/i) { - die "Error: invalid 'type' at $defs_file line $line\n"; - } - - $defs{$strip}{'type'} = $1; - } - elsif (/^searchpage\s+(.+)$/i) - { - $defs{$strip}{'searchpage'} = $1; - } - elsif (/^searchpattern\s+(.+)$/i) - { - $defs{$strip}{'searchpattern'} = $1; - } - elsif (/^searchpattern2\s+(.+)$/i) - { - $defs{$strip}{'searchpattern2'} = $1; - } - elsif (/^matchpart\s+(.+)$/i) - { - unless ($1 =~ /^(\d+)$/) { - die "Error: invalid 'matchpart' at $defs_file line $line\n"; - } - - $defs{$strip}{'matchpart'} = $1; - } - elsif (/^baseurl\s+(.+)$/i) - { - $defs{$strip}{'baseurl'} = $1; - } - elsif (/^urlsuffix\s+(.+)$/i) - { - $defs{$strip}{'urlsuffix'} = $1; - } - elsif (/^imageurl\s+(.+)$/i) - { - $defs{$strip}{'imageurl'} = $1; - } - elsif (/^referer\s+(.+)$/i) - { - $defs{$strip}{'referer'} = $1; - } - elsif (/^prefetch\s+(.+)$/i) - { - $defs{$strip}{'prefetch'} = $1; - } - elsif (/^(\$\d)\s+(.+)$/) - { - $defs{$strip}{$1} = $2; - } - elsif (/^provides\s+(.+)$/i) - { - unless ($1 =~ /^(any|latest)$/i) { - die "Error: invalid 'provides' at $defs_file line $line\n"; - } - - $defs{$strip}{'provides'} = $1; - } - elsif (/^artist\s+(.+)$/i) - { - $defs{$strip}{'artist'} = $1; - } - elsif (/^(.+)\s+?/) - { - die "Error: Unknown keyword '$1' at $defs_file line $line, in strip $strip\n"; - } - } elsif ($sectype eq "group") { - if (/^desc\s+(.+)$/i) - { - $groups{$group}{'desc'} = $1; - } - elsif (/^include\s+(.+)$/i) - { - $groups{$group}{'strips'} .= join(';', split(/\s+/, $1)) . ";"; - } - elsif (/^exclude\s+(.+)$/i) - { - $groups{$group}{'nostrips'} .= join(';', split(/\s+/, $1)) . ";"; - } - elsif (/^(.+)\s+?/) - { - die "Error: Unknown keyword '$1' at $defs_file line $line, in group $group\n"; - } - } - } - - # Post-processing validation - for $group (keys %groups) { - my (@strips, %nostrips, @okstrips); - - if (defined($groups{$group}{'nostrips'})) { - @strips = sort(keys(%defs)); - foreach (split (/;/,$groups{$group}{'nostrips'})) { - $nostrips{$_} = 1; - } - } else { - @strips = split(/;/, $groups{$group}{'strips'}); - %nostrips = (); #empty - } - - foreach (@strips) { - unless ($defs{$_}) { - warn "Warning: group $group references non-existant strip $_\n"; - } - - next if ($nostrips{$_}); - push (@okstrips,$_); - } - $groups{$group}{'strips'} = join(';',@okstrips); - } - + my $defs_file = shift; + my ( $strip, $class, $sectype, $group ); + my $line; + + unless ( open( DEFS, "<$defs_file" ) ) { + die "Error: could not open strip definitions file $defs_file\n"; + } + + my @defs_file = ; + close(DEFS); + + if ( $options{'verbose'} ) { + warn "Loading definitions from file $defs_file\n"; + } + + for (@defs_file) { + $line++; + + chomp; + s/#(.*)//; + s/^\s*//; + s/\s*$//; + + next if $_ eq ""; + + if ( !$sectype ) { + if (/^strip\s+(\w+)$/i) { + if ( defined( $defs{$1} ) ) { + undef $defs{$1}; + } + + $strip = $1; + $sectype = "strip"; + } + elsif (/^class\s+(.*)$/i) { + if ( defined( $classes{$1} ) ) { + undef $classes{$1}; + } + + $class = $1; + $sectype = "class"; + } + elsif (/^group\s+(.*)$/i) { + if ( defined( $groups{$1} ) ) { + undef $groups{$1}; + } + + $group = $1; + $sectype = "group"; + } + elsif (/^(.*)/) { + die "Error: Unknown keyword '$1' at $defs_file line $line\n"; + } + } + elsif (/^end$/i) { + if ( $sectype eq "class" ) { + undef $class; + } + elsif ( $sectype eq "strip" ) { + if ( $defs{$strip}{'useclass'} ) { + my $using_class = $defs{$strip}{'useclass'}; + + # import vars from class + for ( + qw(homepage searchpage searchpattern baseurl imageurl urlsuffix referer prefetch artist drmurl searchpattern2) + ) + { + if ( $classes{$using_class}{$_} and !$defs{$strip}{$_} ) + { + my $classvar = $classes{$using_class}{$_}; + $classvar =~ s/(\$[0-9])/$defs{$strip}{$1}/g; + $classvar =~ s/\$strip/$strip/g; + $defs{$strip}{$_} = $classvar; + } + } + + for (qw(type matchpart provides)) { + if ( $classes{$using_class}{$_} and !$defs{$strip}{$_} ) + { + $defs{$strip}{$_} = $classes{$using_class}{$_}; + } + } + } + + #substitute auto vars for real vals here/set defaults + unless ( $defs{$strip}{'searchpage'} ) { + $defs{$strip}{'searchpage'} = $defs{$strip}{'homepage'}; + } + unless ( $defs{$strip}{'referer'} ) { + if ( $defs{$strip}{'searchpage'} ) { + $defs{$strip}{'referer'} = $defs{$strip}{'searchpage'}; + } + else { + $defs{$strip}{'referer'} = $defs{$strip}{'homepage'}; + } + } + + #other vars in definition + for ( + qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer prefetch) + ) + { + if ( $defs{$strip}{$_} ) { + $defs{$strip}{$_} =~ + s/\$(name|homepage|searchpage|searchpattern|imageurl|baseurl|referer|prefetch)/$defs{$strip}{$1}/g; + } + } + + #dates + for ( + qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer prefetch) + ) + { + if ( $defs{$strip}{$_} ) { + $defs{$strip}{$_} =~ + s/(\%(-?)[a-zA-Z])/strftime("$1", @localtime_today)/ge; + } + } + + # stuff + for ( + qw(homepage searchpage searchpattern imageurl baseurl urlsuffix referer) + ) + { + if ( $defs{$strip}{$_} ) { + $defs{$strip}{$_} =~ + s//&my_eval($1)/ge; + } + } + + #sanity check vars + for (qw(name homepage type)) { + unless ( $defs{$strip}{$_} ) { + die "Error: strip $strip has no '$_' value\n"; + } + } + + for (qw(homepage searchpage baseurl imageurl)) { + if ( $defs{$strip}{$_} + and $defs{$strip}{$_} !~ /^http:\/\//io ) + { + die "Error: strip $strip has invalid $_\n"; + } + } + + if ( $defs{$strip}{'type'} eq "search" ) { + unless ( $defs{$strip}{'searchpattern'} ) { + die + "Error: strip $strip has no 'searchpattern' value in $defs_file\n"; + } + + unless ( $defs{$strip}{'searchpattern'} =~ /\(.+\)/ ) { + die + "Error: strip $strip has no parentheses in searchpattern\n"; + } + + unless ( $defs{$strip}{'matchpart'} ) { + + #die "Error: strip $strip has no 'matchpart' value in $defs_file\n"; + $defs{$strip}{'matchpart'} = 1; + } + + if ( + $defs{$strip}{'imageurl'} + and ( $defs{$strip}{'baseurl'} + or $defs{$strip}{'urlsuffix'} ) + ) + { + die + "Error: strip $strip: cannot use both 'imageurl' at the same time as 'baseurl'\nor 'urlsuffix'\n"; + } + } + elsif ( $defs{$strip}{'type'} eq "generate" ) { + unless ( $defs{$strip}{'imageurl'} ) { + die + "Error: strip $strip has no 'imageurl' value in $defs_file\n"; + } + } + + unless ( $defs{$strip}{'provides'} ) { + die + "Error: strip $strip has no 'provides' value in $defs_file\n"; + } + + #debugger + #foreach my $strip (keys %defs) { + # foreach my $key (qw(homepage searchpage searchpattern imageurl baseurl referer prefetch)) { + # warn "DEBUG: $strip:$key=$defs{$strip}{$key}\n"; + # } + # #warn "DEBUG: $strip:name=$defs{$strip}{'name'}\n"; + #} + + undef $strip; + } + elsif ( $sectype eq "group" ) { + chop $groups{$group}{'strips'}; + + unless ( $groups{$group}{'desc'} ) { + $groups{$group}{'desc'} = "[No description]"; + } + + undef $group; + } + + undef $sectype; + } + elsif ( $sectype eq "class" ) { + if (/^homepage\s+(.+)$/i) { + $classes{$class}{'homepage'} = $1; + } + elsif (/^type\s+(.+)$/i) { + unless ( $1 =~ /^(search|generate|flashdrm)$/io ) { + die "Error: invalid type at $defs_file line $line\n"; + } + + $classes{$class}{'type'} = $1; + } + elsif (/^searchpage\s+(.+)$/i) { + $classes{$class}{'searchpage'} = $1; + } + elsif (/^searchpattern\s+(.+)$/i) { + $classes{$class}{'searchpattern'} = $1; + } + elsif (/^matchpart\s+(.+)$/i) { + unless ( $1 =~ /^(\d)$/ ) { + die "Error: invalid 'matchpart' at $defs_file line $line\n"; + } + + $classes{$class}{'matchpart'} = $1; + } + elsif (/^baseurl\s+(.+)$/i) { + $classes{$class}{'baseurl'} = $1; + } + elsif (/^urlsuffix\s+(.+)$/i) { + $classes{$class}{'urlsufix'} = $1; + } + elsif (/^imageurl\s+(.+)$/i) { + $classes{$class}{'imageurl'} = $1; + } + elsif (/^referer\s+(.+)$/i) { + $classes{$class}{'referer'} = $1; + } + elsif (/^prefetch\s+(.+)$/i) { + $classes{$class}{'prefetch'} = $1; + } + elsif (/^provides\s+(.+)$/i) { + unless ( $1 =~ /^(any|latest)$/i ) { + die "Error: invalid 'provides' at $defs_file line $line\n"; + } + + $classes{$class}{'provides'} = $1; + } + elsif (/^artist\s+(.+)$/i) { + $classes{$class}{'artist'} = $1; + } + elsif (/^drmurl\s+(.+)$/i) { + $classes{$class}{'drmurl'} = $1; + } + elsif (/^(.+)\s+?/) { + die "Unknown keyword '$1' at $defs_file line $line\n"; + } + } + elsif ( $sectype eq "strip" ) { + if (/^name\s+(.+)$/i) { + $defs{$strip}{'name'} = $1; + } + elsif (/^useclass\s+(.+)$/i) { + unless ( defined $classes{$1} ) { + die + "Error: strip $strip references invalid class $1 at $defs_file line $line\n"; + } + + $defs{$strip}{'useclass'} = $1; + } + elsif (/^homepage\s+(.+)$/i) { + $defs{$strip}{'homepage'} = $1; + } + elsif (/^type\s+(.+)$/i) { + unless ( $1 =~ + /^(search|generate|flashdrm|search2pages|doublesearch)$/i ) + { + die "Error: invalid 'type' at $defs_file line $line\n"; + } + + $defs{$strip}{'type'} = $1; + } + elsif (/^searchpage\s+(.+)$/i) { + $defs{$strip}{'searchpage'} = $1; + } + elsif (/^searchpattern\s+(.+)$/i) { + $defs{$strip}{'searchpattern'} = $1; + } + elsif (/^searchpattern2\s+(.+)$/i) { + $defs{$strip}{'searchpattern2'} = $1; + } + elsif (/^matchpart\s+(.+)$/i) { + unless ( $1 =~ /^(\d+)$/ ) { + die "Error: invalid 'matchpart' at $defs_file line $line\n"; + } + + $defs{$strip}{'matchpart'} = $1; + } + elsif (/^baseurl\s+(.+)$/i) { + $defs{$strip}{'baseurl'} = $1; + } + elsif (/^urlsuffix\s+(.+)$/i) { + $defs{$strip}{'urlsuffix'} = $1; + } + elsif (/^imageurl\s+(.+)$/i) { + $defs{$strip}{'imageurl'} = $1; + } + elsif (/^referer\s+(.+)$/i) { + $defs{$strip}{'referer'} = $1; + } + elsif (/^prefetch\s+(.+)$/i) { + $defs{$strip}{'prefetch'} = $1; + } + elsif (/^(\$\d)\s+(.+)$/) { + $defs{$strip}{$1} = $2; + } + elsif (/^provides\s+(.+)$/i) { + unless ( $1 =~ /^(any|latest)$/i ) { + die "Error: invalid 'provides' at $defs_file line $line\n"; + } + + $defs{$strip}{'provides'} = $1; + } + elsif (/^artist\s+(.+)$/i) { + $defs{$strip}{'artist'} = $1; + } + elsif (/^(.+)\s+?/) { + die + "Error: Unknown keyword '$1' at $defs_file line $line, in strip $strip\n"; + } + } + elsif ( $sectype eq "group" ) { + if (/^desc\s+(.+)$/i) { + $groups{$group}{'desc'} = $1; + } + elsif (/^include\s+(.+)$/i) { + $groups{$group}{'strips'} .= + join( ';', split( /\s+/, $1 ) ) . ";"; + } + elsif (/^exclude\s+(.+)$/i) { + $groups{$group}{'nostrips'} .= + join( ';', split( /\s+/, $1 ) ) . ";"; + } + elsif (/^(.+)\s+?/) { + die + "Error: Unknown keyword '$1' at $defs_file line $line, in group $group\n"; + } + } + } + + # Post-processing validation + for $group ( keys %groups ) { + my ( @strips, %nostrips, @okstrips ); + + if ( defined( $groups{$group}{'nostrips'} ) ) { + @strips = sort( keys(%defs) ); + foreach ( split( /;/, $groups{$group}{'nostrips'} ) ) { + $nostrips{$_} = 1; + } + } + else { + @strips = split( /;/, $groups{$group}{'strips'} ); + %nostrips = (); #empty + } + + foreach (@strips) { + unless ( $defs{$_} ) { + warn "Warning: group $group references non-existant strip $_\n"; + } + + next if ( $nostrips{$_} ); + push( @okstrips, $_ ); + } + $groups{$group}{'strips'} = join( ';', @okstrips ); + } + } sub my_eval { - my ($code) = @_; - - $code =~ s/\\\>/\>/g; - - return eval $code; - #print STDERR "DEBUG: eval returned: " . scalar(eval $code) . ", errors: $!\n"; + my ($code) = @_; + + $code =~ s/\\\>/\>/g; + + return eval $code; + + #print STDERR "DEBUG: eval returned: " . scalar(eval $code) . ", errors: $!\n"; } sub make_avantgo_table { - my ($file, $file_ext) = @_; - my ($rows, $cols, $table); - - my $dimensions = `identify \"$file\"`; - - $dimensions =~ m/^$file (\d+)x(\d+)/; - my $width = $1; my $height = $2; - - if (int($width/160) != ($width/160)) { - $cols = int($width/160) + 1; - } else { - $cols = $width/160; - } - - if (int($height/160) != ($height/160)) { - $rows = int($height/160) + 1; - } else { - $rows = $height/160; - } - - my $file_base = $file; $file_base =~ s/$file_ext$//; - - $file_base =~ s/ /\%20/g; - - $table = ""; - foreach my $row (0 .. ($rows-1)) { - $table .= ""; - foreach my $col (0 .. ($cols-1)) { - $table .= ""; - - } - $table .= ""; - } - $table .= "
"; - - return $table; + my ( $file, $file_ext ) = @_; + my ( $rows, $cols, $table ); + + my $dimensions = `identify \"$file\"`; + + $dimensions =~ m/^$file (\d+)x(\d+)/; + my $width = $1; + my $height = $2; + + if ( int( $width / 160 ) != ( $width / 160 ) ) { + $cols = int( $width / 160 ) + 1; + } + else { + $cols = $width / 160; + } + + if ( int( $height / 160 ) != ( $height / 160 ) ) { + $rows = int( $height / 160 ) + 1; + } + else { + $rows = $height / 160; + } + + my $file_base = $file; + $file_base =~ s/$file_ext$//; + + $file_base =~ s/ /\%20/g; + + $table = ""; + foreach my $row ( 0 .. ( $rows - 1 ) ) { + $table .= ""; + foreach my $col ( 0 .. ( $cols - 1 ) ) { + $table .= + ""; + + } + $table .= ""; + } + $table .= "
"; + + return $table; } sub make_avantgo_files { - my ($file, $file_ext) = @_; + my ( $file, $file_ext ) = @_; - my $file_base = $file; $file_base =~ s/$file_ext$//; + my $file_base = $file; + $file_base =~ s/$file_ext$//; - system("convert -crop 160x160 \"$file\" \"$file_base-\%d$file_ext\""); + system("convert -crop 160x160 \"$file\" \"$file_base-\%d$file_ext\""); } -sub get_homedir -{ - if ($^O =~ /Win32/ ) - { - my $dir = $ENV{'USERPROFILE'}; - if ($dir eq "") {$dir = $ENV{'WINDIR'};} - $dir =~ s|\\|/|g; - return $dir; - } - else - { - return (getpwuid($>))[7]; - } +sub get_homedir { + if ( $^O =~ /Win32/ ) { + my $dir = $ENV{'USERPROFILE'}; + if ( $dir eq "" ) { $dir = $ENV{'WINDIR'}; } + $dir =~ s|\\|/|g; + return $dir; + } + else { + return ( getpwuid($>) )[7]; + } } diff --git a/bin/dailystrips-clean b/bin/dailystrips-clean index 9223c1089..94999b319 100755 --- a/bin/dailystrips-clean +++ b/bin/dailystrips-clean @@ -12,7 +12,6 @@ # Current Revision: 1.0.1 # - # Set up use strict; no strict qw(refs); @@ -20,24 +19,22 @@ no strict qw(refs); use POSIX qw(strftime); use Getopt::Long; - # Variables -my (%options, $version, $time_today, @files); +my ( %options, $version, $time_today, @files ); $version = "1.0.1"; $time_today = time; - # Get options -GetOptions(\%options, 'quiet|q','verbose|v','test|t','dir=s','archive|a','version|v','help|h') - or exit 1; - +GetOptions( + \%options, 'quiet|q', 'verbose|v', 'test|t', + 'dir=s', 'archive|a', 'version|v', 'help|h' +) or exit 1; # Help and version override anything else -if ($options{'help'}) { - print -"Usage: $0 [OPTIONS] DAYS +if ( $options{'help'} ) { + print "Usage: $0 [OPTIONS] DAYS DAYS is the number of days to keep. Options: @@ -52,121 +49,113 @@ Options: Bugs and comments to dailystrips\@amedico.dhs.org\n"; - exit; + exit; } -if ($options{'version'}) { - print "dailystrips-clean version $version\n"; - exit; +if ( $options{'version'} ) { + print "dailystrips-clean version $version\n"; + exit; } - -unless (defined $ARGV[0]) { - die "Error: no number of days specified\n"; -} else { - $options{'days'} = $ARGV[0]; - if ($options{'days'} =~ m/\D/) { - die "Error:number of days must be numeric\n"; - } - - if ($options{'days'} =~ m/\D/) { - die "Error:number of days must be numeric\n"; - } +unless ( defined $ARGV[0] ) { + die "Error: no number of days specified\n"; +} +else { + $options{'days'} = $ARGV[0]; + if ( $options{'days'} =~ m/\D/ ) { + die "Error:number of days must be numeric\n"; + } + + if ( $options{'days'} =~ m/\D/ ) { + die "Error:number of days must be numeric\n"; + } } - # verbose overrides quiet -if ($options{'verbose'} and $options{'quiet'}) { - undef $options{'quiet'}; +if ( $options{'verbose'} and $options{'quiet'} ) { + undef $options{'quiet'}; } - - # get list of existing files -if ($options{'dir'} and (not $options{'dir'} =~ /\/$/)) { - $options{'dir'} .= "/"; +if ( $options{'dir'} and ( not $options{'dir'} =~ /\/$/ ) ) { + $options{'dir'} .= "/"; } -@files = grep(/\d{4}\.\d{2}\.\d{2}/, glob("$options{'dir'}*")); +@files = grep( /\d{4}\.\d{2}\.\d{2}/, glob("$options{'dir'}*") ); for (@files) { - if ($options{'verbose'}) { - print "Existing file: $_\n"; - } + if ( $options{'verbose'} ) { + print "Existing file: $_\n"; + } } - # filter out files to keep -for (0 .. $options{'days'} - 1) { - my $save_day = strftime("\%Y.\%m.\%d", localtime ($time_today - (86400 * $_))); - - unless ($options{'quiet'}) { - print "Keeping files for: $save_day\n"; - } - - @files = grep(!/$save_day/, @files); +for ( 0 .. $options{'days'} - 1 ) { + my $save_day = + strftime( "\%Y.\%m.\%d", localtime( $time_today - ( 86400 * $_ ) ) ); + + unless ( $options{'quiet'} ) { + print "Keeping files for: $save_day\n"; + } + + @files = grep( !/$save_day/, @files ); } # remove anything that's still on the list for (@files) { - if ($options{'verbose'}) { - print "Removing file/directory: $_\n"; - } - - unless ($options{'test'}) { - if (-d $_) { - my $dir_not_empty; - - foreach my $sub (glob("$_/*")) { - unless (unlink("$sub")) { - warn "Could not remove file $sub: $!\n"; - $dir_not_empty = 1; - } - } - - if ($dir_not_empty) { - warn "Directory $_ not empty, cannot remove\n"; - } else { - rmdir($_) or warn "Could not remove directory $_: $!\n"; - } - } - - else { - unlink($_) or warn "Could not remove file $_: $!\n"; - } - } + if ( $options{'verbose'} ) { + print "Removing file/directory: $_\n"; + } + + unless ( $options{'test'} ) { + if ( -d $_ ) { + my $dir_not_empty; + + foreach my $sub ( glob("$_/*") ) { + unless ( unlink("$sub") ) { + warn "Could not remove file $sub: $!\n"; + $dir_not_empty = 1; + } + } + + if ($dir_not_empty) { + warn "Directory $_ not empty, cannot remove\n"; + } + else { + rmdir($_) or warn "Could not remove directory $_: $!\n"; + } + } + + else { + unlink($_) or warn "Could not remove file $_: $!\n"; + } + } } -if ($options{'archive'}) -{ - if (open(ARCHIVE,"<$options{'dir'}archive.html")) - { - my $oldest = strftime("\%Y.\%m.\%d", localtime ($time_today - (86400 * ($options{'days'}-1)))); - my $out; - - while() - { - if (/(\d{4}\.\d{2}\.\d{2})/) - { - if ($1 lt $oldest) - { - $_ = ""; - } - } - $out .= $_; - } - - close(ARCHIVE); - if (open(ARCHIVE,">$options{'dir'}archive.html")) - { - print ARCHIVE $out; - } - else - { - warn "Error: cannot update archive.html - could not write file: $!\n"; - } - } - else - { - warn "Error: cannot update archive.html - could not read file: $!\n"; - } -} \ No newline at end of file +if ( $options{'archive'} ) { + if ( open( ARCHIVE, "<$options{'dir'}archive.html" ) ) { + my $oldest = strftime( "\%Y.\%m.\%d", + localtime( $time_today - ( 86400 * ( $options{'days'} - 1 ) ) ) ); + my $out; + + while () { + if (/(\d{4}\.\d{2}\.\d{2})/) { + if ( $1 lt $oldest ) { + $_ = ""; + } + } + $out .= $_; + } + + close(ARCHIVE); + if ( open( ARCHIVE, ">$options{'dir'}archive.html" ) ) { + print ARCHIVE $out; + } + else { + warn + "Error: cannot update archive.html - could not write file: $!\n"; + } + } + else { + warn "Error: cannot update archive.html - could not read file: $!\n"; + } +} diff --git a/bin/display b/bin/display index 38b65162f..6ba7408db 100755 --- a/bin/display +++ b/bin/display @@ -2,19 +2,20 @@ use strict; -my($Pgm_Path, $Pgm_Name); +my ( $Pgm_Path, $Pgm_Name ); + BEGIN { - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.*)\.?/; + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.*)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; - eval "use lib '$Pgm_Path/../lib'"; # Use BEGIN eval to keep perl2exe happy + eval "use lib '$Pgm_Path/../lib'"; # Use BEGIN eval to keep perl2exe happy } - -use Getopt::Long; -my %parm = (); -if (!&GetOptions(\%parm, "help", "h", "time=s", "title=s", "font=s") or - (@ARGV < 1 or $parm{h} or $parm{help})) { - print < 2 or $parms{h} or $parms{help}) { - print< 2 + or $parms{h} + or $parms{help} ) +{ + print < 'New Window'); + if ( $parms{cgi} ) { + eval "use CGI ':all';" + ; # Use eval so we don't fail if CGI not available (e.g. mh.exe) + print &header( -target => 'New Window' ); print &start_html("Phone Logs"); print "

Phone Logs

\n"; } else { - # In case we were called from mh that has -tk - if ($main::MW) { - $MW = $main::MW->Toplevel; + # In case we were called from mh that has -tk + if ($main::MW) { + $MW = $main::MW->Toplevel; $loop = 0; - } - else { - use Tk; - $MW = MainWindow->new; + } + else { + use Tk; + $MW = MainWindow->new; $loop = 1; - } - - $MW->title('display_calls: Phone Log Display'); - - $MW->geometry($config_parms{tk_display_callers_geometry}) if $MW and $config_parms{tk_display_callers_geometry}; - - $MW->bind('' => \&my_exit); - $MW->bind('' => \&my_exit); - $MW->bind('' => \&my_exit); - $MW->bind('' => \&my_exit); - - $MW->configure(-bg => 'white'); -# $MW->optionAdd('*font' => 'systemfixed'); - - @pl1 = qw/-expand yes -fill both -side top -padx 2/; - @pl2 = qw/-expand yes -fill both -side left -padx 2/; - @pl3 = qw/-side left -ipadx 5/; + } + + $MW->title('display_calls: Phone Log Display'); + + $MW->geometry( $config_parms{tk_display_callers_geometry} ) + if $MW and $config_parms{tk_display_callers_geometry}; + + $MW->bind( '' => \&my_exit ); + $MW->bind( '' => \&my_exit ); + $MW->bind( '' => \&my_exit ); + $MW->bind( '' => \&my_exit ); + + $MW->configure( -bg => 'white' ); + + # $MW->optionAdd('*font' => 'systemfixed'); + + @pl1 = qw/-expand yes -fill both -side top -padx 2/; + @pl2 = qw/-expand yes -fill both -side left -padx 2/; + @pl3 = qw/-side left -ipadx 5/; + } + +} + +sub read_member_list { + + # Read directory for list of detailed phone logs ... default to the lastest one. + # print "Read member list\n"; + opendir( DIR, "$dir/logs" ) + or die "Could not open directory $dir/logs: $!\n"; + my @members = readdir(DIR); + @members1 = reverse sort grep( /callerid.*$file_qual.*log$/, @members ) + ; # ... should sort by -M instead of name ?? + @members2 = reverse sort grep( /phone.*$file_qual.*log$/, @members ); + + # Default to just the latest member + unless (@members_picked1) { + @members_picked1 = ( $members1[0] ); + } + unless (@members_picked2) { + @members_picked2 = ( $members2[0] ); } + # print "members1=@members1\nmembers_picked1=@members_picked1\n"; + # print "members2=@members2\nmembers_picked2=@members_picked2\n"; } -sub read_member_list { - # Read directory for list of detailed phone logs ... default to the lastest one. -# print "Read member list\n"; - opendir(DIR, "$dir/logs") or die "Could not open directory $dir/logs: $!\n"; - my @members = readdir(DIR); - @members1 = reverse sort grep(/callerid.*$file_qual.*log$/, @members); # ... should sort by -M instead of name ?? - @members2 = reverse sort grep(/phone.*$file_qual.*log$/, @members); - # Default to just the latest member - unless (@members_picked1) { - @members_picked1 = ($members1[0]); - } - unless (@members_picked2) { - @members_picked2 = ($members2[0]); - } -# print "members1=@members1\nmembers_picked1=@members_picked1\n"; -# print "members2=@members2\nmembers_picked2=@members_picked2\n"; +sub read_callerid_list { + print "Reading override phone list\n"; + open( CALLERID, $config_parms{caller_id_file} ) + or print + "Error, could not open mh.ini caller_id_file=$config_parms{caller_id_file}: $!\n"; + + my $callerid_cnt = 0; + while () { + next if /^\#/; + my ( $number, $name ) = $_ =~ /^(\S+) +(.+) *$/; + next unless $name; + $callerid_cnt++; + $name =~ s/\.wav$//; # Delete wav extentions + $callerid_name_by_number{$number} = $name; + } + + # print "read in $callerid_cnt caller ID override names/numbers from $config_parms{caller_id_file}\n"; + close CALLERID; } -sub read_callerid_list { - print "Reading override phone list\n"; - open (CALLERID, $config_parms{caller_id_file}) or print "Error, could not open mh.ini caller_id_file=$config_parms{caller_id_file}: $!\n"; - - my $callerid_cnt=0; - while () { - next if /^\#/; - my ($number, $name) = $_ =~ /^(\S+) +(.+) *$/; - next unless $name; - $callerid_cnt++; - $name =~ s/\.wav$//; # Delete wav extentions - $callerid_name_by_number{$number} = $name; - } -# print "read in $callerid_cnt caller ID override names/numbers from $config_parms{caller_id_file}\n"; - close CALLERID; -} - -sub read_dbm_file { - # Read the dbm file that tracks all callers who have ever called us - # Useful in associating a name with the numbers we dial out. - my $dbm_file = "$dir/callerid.dbm"; - print "Reading $dbm_file\n"; - my %DBM; - - # Use tie, instead of dbmopen, so perl2exe works OK. -# dbmopen %DBM, $dbm_file, 0666 or die "Can not open dbm file $dbm_file: $!\n"; - -# use Fcntl; -# use SDBM_File; +sub read_dbm_file { + + # Read the dbm file that tracks all callers who have ever called us + # Useful in associating a name with the numbers we dial out. + my $dbm_file = "$dir/callerid.dbm"; + print "Reading $dbm_file\n"; + my %DBM; + + # Use tie, instead of dbmopen, so perl2exe works OK. + # dbmopen %DBM, $dbm_file, 0666 or die "Can not open dbm file $dbm_file: $!\n"; + + # use Fcntl; + # use SDBM_File; use DB_File; -# tie (%DBM, 'SDBM_File', $dbm_file, O_RDWR|O_CREAT, 0666) or die "Can not open dbm file $dbm_file: $!"; - tie (%DBM, 'DB_File', $dbm_file, O_RDWR|O_CREAT, 0666) or die "Can not open dbm file $dbm_file: $!"; - - my $count = 0; - delete $calls{dbm}; - my ($number, $data); - while (($number, $data) = each %DBM) { -# $data =~ tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up -# print "1 number=$number data=$data\n" if $data =~ /SPENSER/i or $number =~ /8619/ or $number =~ /5307/; -# next if $data =~ /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records ... should filter these out of source file. - next if $data =~ /[^\x20-\x7e]/; # Ignore messed up records ... should filter these out of source file. - next if $number =~ /[^\x20-\x7e]/; # Ignore messed up records ... should filter these out of source file. -#2 3:53 PM Sat, Dec 27 1997 name=WINTER BRUCE LA - my ($calls, $time, $date, $name) = $data =~ /^(\d+) +(.+), (.+) name=(.+)/; - next unless $name; - $dbm_name_by_number{$number} = $name; - - $count++; - $calls{dbm}{$count}{calls} = sprintf("%04d", $calls); - $calls{dbm}{$count}{date} = sprintf("last=%010d calls=%4d", parsedate($date), $calls); - - $calls{dbm}{$count}{'# calls'} = sprintf("%04d", $calls); # Since we do not have a sortable date here, sort on number of calls. - $calls{dbm}{$count}{time_date} = sprintf("last=%s calls=%4d", $date, $calls); - $calls{dbm}{$count}{number} = $number; - $calls{dbm}{$count}{name} = $name; - + + # tie (%DBM, 'SDBM_File', $dbm_file, O_RDWR|O_CREAT, 0666) or die "Can not open dbm file $dbm_file: $!"; + tie( %DBM, 'DB_File', $dbm_file, O_RDWR | O_CREAT, 0666 ) + or die "Can not open dbm file $dbm_file: $!"; + + my $count = 0; + delete $calls{dbm}; + my ( $number, $data ); + while ( ( $number, $data ) = each %DBM ) { + + # $data =~ tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up + # print "1 number=$number data=$data\n" if $data =~ /SPENSER/i or $number =~ /8619/ or $number =~ /5307/; + # next if $data =~ /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records ... should filter these out of source file. + next + if $data =~ /[^\x20-\x7e]/ + ; # Ignore messed up records ... should filter these out of source file. + next + if $number =~ /[^\x20-\x7e]/ + ; # Ignore messed up records ... should filter these out of source file. + + #2 3:53 PM Sat, Dec 27 1997 name=WINTER BRUCE LA + my ( $calls, $time, $date, $name ) = + $data =~ /^(\d+) +(.+), (.+) name=(.+)/; + next unless $name; + $dbm_name_by_number{$number} = $name; + + $count++; + $calls{dbm}{$count}{calls} = sprintf( "%04d", $calls ); + $calls{dbm}{$count}{date} = + sprintf( "last=%010d calls=%4d", parsedate($date), $calls ); + + $calls{dbm}{$count}{'# calls'} = sprintf( "%04d", $calls ) + ; # Since we do not have a sortable date here, sort on number of calls. + $calls{dbm}{$count}{time_date} = + sprintf( "last=%s calls=%4d", $date, $calls ); + $calls{dbm}{$count}{number} = $number; + $calls{dbm}{$count}{name} = $name; + my $name2 = $callerid_name_by_number{$number}; $name2 = $name unless $name2; - $calls{dbm}{$count}{name2} = $name2; - } - close DBM; + $calls{dbm}{$count}{name2} = $name2; + } + close DBM; } +sub read_in_call_log { -sub read_in_call_log { + print "Read Incoming phone logs\n"; + my $count = 0; + delete $calls{in}; - print "Read Incoming phone logs\n"; - my $count = 0; - delete $calls{in}; - # Sort by date, so most recent file is last - my($log_file); - foreach $log_file (sort {-M $b <=> -M $a} @members_picked1) { + # Sort by date, so most recent file is last + my ($log_file); + foreach $log_file ( sort { -M $b <=> -M $a } @members_picked1 ) { next unless $log_file; $log_file = "$dir/logs/$log_file"; -# print "Reading $log_file, date=", -M $log_file, ".\n"; - open (DATA, $log_file) or die "Error, could not open file $log_file: $!\n"; - binmode DATA; # In case bad (binary) data is logged - while () { - -# next if /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records - tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up - -#Tue, Nov 2 6:46 PM 507-252-8619 SPENCER DARYL -#Mon 04/14/97 14:28:00 - -#Sat 12/15/01 17:37:51 507-281-3888 name=TACINELLI JOHN data=###DATE12151737...NMBR5072813888...NAMETACINELLI JOHN +++ line=W - - my($time_date, $number, $name) = $_ =~ /(.+?)(\d\d\d\-?\d\d\d\-?\d\d\d\d) (.+)$/; - my ($line) = $_ =~ /line=(.+?)/; # Optional ... which incoming line + + # print "Reading $log_file, date=", -M $log_file, ".\n"; + open( DATA, $log_file ) + or die "Error, could not open file $log_file: $!\n"; + binmode DATA; # In case bad (binary) data is logged + while () { + + # next if /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records + tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up + + #Tue, Nov 2 6:46 PM 507-252-8619 SPENCER DARYL + #Mon 04/14/97 14:28:00 + + #Sat 12/15/01 17:37:51 507-281-3888 name=TACINELLI JOHN data=###DATE12151737...NMBR5072813888...NAMETACINELLI JOHN +++ line=W + + my ( $time_date, $number, $name ) = + $_ =~ /(.+?)(\d\d\d\-?\d\d\d\-?\d\d\d\d) (.+)$/; + my ($line) = $_ =~ /line=(.+?)/; # Optional ... which incoming line $name =~ s/^name=//; - - # Deal with "private, 'out of area', and bad data" calls - unless ($name) { - $time_date = substr($_, 0, 21); - $number = substr($_, 21, 12); -# $name = substr($_, 34, 15); - if ($number =~ /OUT OF AREA/) { - $number = " Out of Area"; - } - elsif ($number =~ /PRIVATE/) { - $number = " Private"; - } - else { - $number = ' Lost Data'; - $name = " " . substr($_, 21); - } - } + + # Deal with "private, 'out of area', and bad data" calls + unless ($name) { + $time_date = substr( $_, 0, 21 ); + $number = substr( $_, 21, 12 ); + + # $name = substr($_, 34, 15); + if ( $number =~ /OUT OF AREA/ ) { + $number = " Out of Area"; + } + elsif ( $number =~ /PRIVATE/ ) { + $number = " Private"; + } + else { + $number = ' Lost Data'; + $name = " " . substr( $_, 21 ); + } + } $time_date =~ s/ +$//; $name =~ s/data=.+//; $name =~ s/line=.+//; - -# $name =~ s/[\r\n]+$//; # Delete carrage return + + # $name =~ s/[\r\n]+$//; # Delete carrage return my $name2 = $callerid_name_by_number{$number}; $name2 = $name unless $name2; - -# my $number_name = sprintf("$line %-12s %s", $number, $name2); - - $count++; -# $calls{out}{$count}{date} =&ParseDate($time_date); # For sorting by date .... MUCH too slow :( - $calls{in}{$count}{date} = sprintf("%05d", $count); # Make cmp sortable - $calls{in}{$count}{time_date} = $time_date; - $calls{in}{$count}{number} = $number; - $calls{in}{$count}{name} = $name; - $calls{in}{$count}{name2} = $name2; - $calls{in}{$count}{line} = $line; - - } + + # my $number_name = sprintf("$line %-12s %s", $number, $name2); + + $count++; + + # $calls{out}{$count}{date} =&ParseDate($time_date); # For sorting by date .... MUCH too slow :( + $calls{in}{$count}{date} = + sprintf( "%05d", $count ); # Make cmp sortable + $calls{in}{$count}{time_date} = $time_date; + $calls{in}{$count}{number} = $number; + $calls{in}{$count}{name} = $name; + $calls{in}{$count}{name2} = $name2; + $calls{in}{$count}{line} = $line; + + } close DATA; } } -sub read_out_call_log { - # Read log of Outgoing phone calls - print "Read Outgoing phone logs\n"; - my $count = 0; - delete $calls{out}; - my($log_file); - foreach $log_file (sort {-M $b <=> -M $a} @members_picked2) { +sub read_out_call_log { + + # Read log of Outgoing phone calls + print "Read Outgoing phone logs\n"; + my $count = 0; + delete $calls{out}; + my ($log_file); + foreach $log_file ( sort { -M $b <=> -M $a } @members_picked2 ) { next unless $log_file; $log_file = "$dir/logs/$log_file"; - open (DATA, $log_file) or die "Error, could not open file $log_file: $!\n"; - binmode DATA; # In case bad (binary) data is logged - while () { -# next if /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records - tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up - -#Tue, Nov 2 9:28 AM O2537009 -#Fri 11/26/99 10:14:06 O2537009 - - my($time_date, $number) = $_ =~ /(.+?) O(\S+)$/; -# my $time_date = substr($_, 0, 21); -# my $number = substr($_, 22); - - # See if we can find a name for this number - my $number_length = length($number); - if ($number_length == 7) { - $number =~ s/(\d\d\d)/$config_parms{local_area_code}-$1-/; - } - if ($number_length == 11) { - $number = substr($number, 1); - $number =~ s/(\d\d\d)(\d\d\d)/$1-$2-/; - } - my $name = $dbm_name_by_number{$number}; + open( DATA, $log_file ) + or die "Error, could not open file $log_file: $!\n"; + binmode DATA; # In case bad (binary) data is logged + while () { + + # next if /[^\x9\xa\xd\x20-\x7e]/; # Ignore messed up records + tr/\x20-\x7e//cd; # Translate bad characters or else TK will mess up + + #Tue, Nov 2 9:28 AM O2537009 + #Fri 11/26/99 10:14:06 O2537009 + + my ( $time_date, $number ) = $_ =~ /(.+?) O(\S+)$/; + + # my $time_date = substr($_, 0, 21); + # my $number = substr($_, 22); + + # See if we can find a name for this number + my $number_length = length($number); + if ( $number_length == 7 ) { + $number =~ s/(\d\d\d)/$config_parms{local_area_code}-$1-/; + } + if ( $number_length == 11 ) { + $number = substr( $number, 1 ); + $number =~ s/(\d\d\d)(\d\d\d)/$1-$2-/; + } + my $name = $dbm_name_by_number{$number}; my $name2 = $callerid_name_by_number{$number}; $name2 = $name unless $name2; $name = $name2 unless $name; - - $count++; - $calls{out}{$count}{date} = sprintf("%05d", $count); # Make cmp sortable - $calls{out}{$count}{time_date} = $time_date; - $calls{out}{$count}{number} = $number; - $calls{out}{$count}{name} = $name; - $calls{out}{$count}{name2} = $name2; - } + + $count++; + $calls{out}{$count}{date} = + sprintf( "%05d", $count ); # Make cmp sortable + $calls{out}{$count}{time_date} = $time_date; + $calls{out}{$count}{number} = $number; + $calls{out}{$count}{name} = $name; + $calls{out}{$count}{name2} = $name2; + } close DATA; - } + } } -#10:28 AM Sat, Dec 27 O2 -#10:29 AM Sat, Dec 27 O2880513 -# 3:48 PM Thu, Dec 25 O18004210699 - -# 1:17 PM Tue, Aug 23 507-288-1030 WINTER BRUCE LA -#10:03 PM Tue, Dec 23 OUT OF AREA OUT OF AREA -# 2:22 PM Wed, Dec 24 507-288-1030 WINTER BRUCE LA -# 4:15 PM Wed, Dec 24 507-269-1033 OUT OF AREA -# 8:37 PM Fri, Dec 26 PRIVATE PRIVATE - - -sub display { - - my $ft = $MW->Frame->pack(@pl1); - my $fb = $MW->Frame->pack(@pl1); - my $ftl = $ft->Frame->pack(@pl2); - my $ftr = $ft->Frame->pack(@pl2); - my $fbl = $fb->Frame->pack(@pl2); - my $fbr = $fb->Frame->pack(@pl2); - - $info{in}{sort} = 'date'; - $info{out}{sort} = 'date'; - $info{dbm}{sort} = 'name'; - $info{in}{label} = 'Incoming calls'; - $info{out}{label} = 'Outgoing calls'; - $info{dbm}{label} = 'Database of callers'; - - my $log1 = &phone_list($ftl, 'in'); - my $log2 = &phone_list($ftr, 'out'); - my $log3 = &phone_list($fbl, 'dbm'); - - $fbr->Label(-text => 'List of log files')->pack; - my $fbr2 = $fbr->Frame->pack(qw/-expand no -fill x/); - $fbr2->Label(-text => 'Incoming files')->pack(qw/-expand yes -fill x -side left/); - $fbr2->Label(-text => 'Outgoing files')->pack(qw/-expand yes -fill x -side left/); - - my($files1, $files2); - $files1 = $fbr->Scrolled(qw/Listbox -selectmode extended -width -1 -height 10 -setgrid 1 -scrollbars e -bg cyan/); - $files1->pack(@pl2)->insert(0, @members1); - $files2 = $fbr->Scrolled(qw/Listbox -selectmode extended -width -1 -height 10 -setgrid 1 -scrollbars e -bg cyan/); - $files2->pack(@pl2)->insert(0, @members2); - -# $files1->activate(0); -# $files2->activate(0); - $files1->selection('set', 0); # Only one listbox widget can have a row slected at a time :( -# $files2->selection('set', 0); - - $files1->bind('' => sub { - @members_picked1 = map{$files1->get($_)} $files1->curselection; - &read_in_call_log; - &sort_data('in'); - }); - $files2->bind('' => sub { - @members_picked2 = map{$files2->get($_)} $files2->curselection; - &read_out_call_log; - &sort_data('out'); - }); - - # tkwait messes up mh 'do' - $log1->tkwait('visibility', $log1) unless ($main::MW); -# $log1->focus('-force'); -# $log1->grabGlobal; -# $log1->grab("-global"); # This will disable the minimize-maximize-etc controls :( + +#10:28 AM Sat, Dec 27 O2 +#10:29 AM Sat, Dec 27 O2880513 +# 3:48 PM Thu, Dec 25 O18004210699 + +# 1:17 PM Tue, Aug 23 507-288-1030 WINTER BRUCE LA +#10:03 PM Tue, Dec 23 OUT OF AREA OUT OF AREA +# 2:22 PM Wed, Dec 24 507-288-1030 WINTER BRUCE LA +# 4:15 PM Wed, Dec 24 507-269-1033 OUT OF AREA +# 8:37 PM Fri, Dec 26 PRIVATE PRIVATE + +sub display { + + my $ft = $MW->Frame->pack(@pl1); + my $fb = $MW->Frame->pack(@pl1); + my $ftl = $ft->Frame->pack(@pl2); + my $ftr = $ft->Frame->pack(@pl2); + my $fbl = $fb->Frame->pack(@pl2); + my $fbr = $fb->Frame->pack(@pl2); + + $info{in}{sort} = 'date'; + $info{out}{sort} = 'date'; + $info{dbm}{sort} = 'name'; + $info{in}{label} = 'Incoming calls'; + $info{out}{label} = 'Outgoing calls'; + $info{dbm}{label} = 'Database of callers'; + + my $log1 = &phone_list( $ftl, 'in' ); + my $log2 = &phone_list( $ftr, 'out' ); + my $log3 = &phone_list( $fbl, 'dbm' ); + + $fbr->Label( -text => 'List of log files' )->pack; + my $fbr2 = $fbr->Frame->pack(qw/-expand no -fill x/); + $fbr2->Label( -text => 'Incoming files' ) + ->pack(qw/-expand yes -fill x -side left/); + $fbr2->Label( -text => 'Outgoing files' ) + ->pack(qw/-expand yes -fill x -side left/); + + my ( $files1, $files2 ); + $files1 = $fbr->Scrolled( + qw/Listbox -selectmode extended -width -1 -height 10 -setgrid 1 -scrollbars e -bg cyan/ + ); + $files1->pack(@pl2)->insert( 0, @members1 ); + $files2 = $fbr->Scrolled( + qw/Listbox -selectmode extended -width -1 -height 10 -setgrid 1 -scrollbars e -bg cyan/ + ); + $files2->pack(@pl2)->insert( 0, @members2 ); + + # $files1->activate(0); + # $files2->activate(0); + $files1->selection( 'set', 0 ) + ; # Only one listbox widget can have a row slected at a time :( + + # $files2->selection('set', 0); + + $files1->bind( + '' => sub { + @members_picked1 = map { $files1->get($_) } $files1->curselection; + &read_in_call_log; + &sort_data('in'); + } + ); + $files2->bind( + '' => sub { + @members_picked2 = map { $files2->get($_) } $files2->curselection; + &read_out_call_log; + &sort_data('out'); + } + ); + + # tkwait messes up mh 'do' + $log1->tkwait( 'visibility', $log1 ) unless ($main::MW); + + # $log1->focus('-force'); + # $log1->grabGlobal; + # $log1->grab("-global"); # This will disable the minimize-maximize-etc controls :( print "Displaying window\n"; @@ -388,78 +443,105 @@ sub display { } sub my_exit { - # Mainloop is local + + # Mainloop is local if ($loop) { - # Normal exit; - if ($0 =~ /display_callers/) { + + # Normal exit; + if ( $0 =~ /display_callers/ ) { exit; } - # Called from another program, kill window and return + + # Called from another program, kill window and return else { $MW->destroy; return; } } - # Mainloop came from a calling program + + # Mainloop came from a calling program else { $MW->destroy; return; } } -sub phone_list { - my($ptr, $class) = @_; -# print "Creating frame for $class\n"; +sub phone_list { + my ( $ptr, $class ) = @_; + + # print "Creating frame for $class\n"; - my $log_label = $ptr->Label(-textvariable => \$info{$class}{label2})->pack; + my $log_label = + $ptr->Label( -textvariable => \$info{$class}{label2} )->pack; my $search_var; - if ($class eq 'dbm') { - my $search_frame = $ptr->Frame->pack; + if ( $class eq 'dbm' ) { + my $search_frame = $ptr->Frame->pack; - my $search_label = $search_frame->Label(-text => "Search:")->pack(-side => 'left'); + my $search_label = + $search_frame->Label( -text => "Search:" )->pack( -side => 'left' ); - my $search_entry = $search_frame->Entry(-textvariable => \$search_var, -width => 10)->pack; - $search_entry -> bind('', sub { &search_data($search_var) } ); + my $search_entry = + $search_frame->Entry( -textvariable => \$search_var, -width => 10 ) + ->pack; + $search_entry->bind( '', sub { &search_data($search_var) } ); } - my $frame = $ptr->Frame->pack; - my $log = $ptr->Scrolled(qw/Text -state normal -width 60 -height 15 -scrollbars e -bg cyan/)->pack(@pl2); - $info{$class}{window} = $log; + my $frame = $ptr->Frame->pack; + my $log = $ptr->Scrolled( + qw/Text -state normal -width 60 -height 15 -scrollbars e -bg cyan/) + ->pack(@pl2); + $info{$class}{window} = $log; - for my $button (qw/name number date calls/) { + for my $button (qw/name number date calls/) { my $button2 = $button; $button2 = '# calls' if $class eq 'dbm' and $button eq 'date'; - $frame->Radiobutton(-text => "Sort by $button", -variable => \$info{$class}{sort}, - -relief => 'flat', -value => $button, - -command => [\&sort_data, $class])->pack(@pl3); - } - - &sort_data($class); - - $log->bind('' => sub { - my $text = $log->get('current linestart +20 chars', 'current lineend'); - $text =~ s/^.*? (\d\d\d-)/$1/; # Delete up to the number - my $popup = $MW->Toplevel; - my $label = $popup->Label(-text=>"Edit name to be more prounancable,\nthen hit enter (or Escape to exit)")->pack(-side=>'top'); - my $entry = $popup->Entry(-width => 40, -textvariable => \$text)->pack(-side=>'bottom'); - - $entry->tkwait('visibility', $entry); - $entry->focus; - - $entry->bind('', sub { - my $callerid_file_override = $config_parms{caller_id_file}; - print "writing to $callerid_file_override\n"; - open (CALLERID, ">>$callerid_file_override") or print "Error opening $callerid_file_override: $!\n"; - print "text=",$entry->get,"\n"; - print CALLERID $entry->get,"\n"; - close CALLERID; -# $MW->focus; -# $MW->focus('-force'); - $popup->destroy; - }); - $popup->bind('', sub {$popup->destroy;}); - }); + $frame->Radiobutton( + -text => "Sort by $button", + -variable => \$info{$class}{sort}, + -relief => 'flat', + -value => $button, + -command => [ \&sort_data, $class ] + )->pack(@pl3); + } + + &sort_data($class); + + $log->bind( + '' => sub { + my $text = + $log->get( 'current linestart +20 chars', 'current lineend' ); + $text =~ s/^.*? (\d\d\d-)/$1/; # Delete up to the number + my $popup = $MW->Toplevel; + my $label = + $popup->Label( -text => + "Edit name to be more prounancable,\nthen hit enter (or Escape to exit)" + )->pack( -side => 'top' ); + my $entry = $popup->Entry( -width => 40, -textvariable => \$text ) + ->pack( -side => 'bottom' ); + + $entry->tkwait( 'visibility', $entry ); + $entry->focus; + + $entry->bind( + '', + sub { + my $callerid_file_override = $config_parms{caller_id_file}; + print "writing to $callerid_file_override\n"; + open( CALLERID, ">>$callerid_file_override" ) + or print "Error opening $callerid_file_override: $!\n"; + print "text=", $entry->get, "\n"; + print CALLERID $entry->get, "\n"; + close CALLERID; + + # $MW->focus; + # $MW->focus('-force'); + $popup->destroy; + } + ); + $popup->bind( '', sub { $popup->destroy; } ); + } + ); return $log; } @@ -467,79 +549,100 @@ sub phone_list { sub search_data { my ($search_var) = @_; print "Searching for $search_var\n"; - # Search data logged from incoming caller id data. - my ($count1, $count2, %results) = &main::search_dbm("$config_parms{data_dir}/phone/callerid.dbm", $search_var); - # Also search in array created from mh.ini caller_id_file data - while (my($key, $value) = each %callerid_name_by_number) { - if ($key =~ /$search_var/i or $value =~ /$search_var/i) { - $value = &main::read_dbm("$config_parms{data_dir}/phone/callerid.dbm", $key); # Use dbm data for consistency + + # Search data logged from incoming caller id data. + my ( $count1, $count2, %results ) = + &main::search_dbm( "$config_parms{data_dir}/phone/callerid.dbm", + $search_var ); + + # Also search in array created from mh.ini caller_id_file data + while ( my ( $key, $value ) = each %callerid_name_by_number ) { + if ( $key =~ /$search_var/i or $value =~ /$search_var/i ) { + $value = + &main::read_dbm( "$config_parms{data_dir}/phone/callerid.dbm", + $key ); # Use dbm data for consistency $results{$key} = $value; } } - $count2 = keys %results; # Reset count, in case Caller_ID search found any + $count2 = keys %results; # Reset count, in case Caller_ID search found any - my $list = $info{dbm}{window}; + my $list = $info{dbm}{window}; -# last=Oct 1 1999 calls= 505 OUT OF AREA OUT OF AREA -# 6:36 PM Tue, Jun 1 1999 + # last=Oct 1 1999 calls= 505 OUT OF AREA OUT OF AREA + # 6:36 PM Tue, Jun 1 1999 my $results; if ($count2) { - for (sort keys %results) { - my ($cid_number, $cid_date, $cid_name) = $results{$_} =~ /(\S+) (.+) name=(.+)/; - $cid_name = $callerid_name_by_number{$_} if $callerid_name_by_number{$_}; - $cid_date = (split(',', $cid_date))[1]; # Drop leading time field -# $results .= sprintf("%15s: %-15s calls=%3s last=%s\n %s\n", $_, $cid_name, $cid_number, $cid_date, $caller); - $results .= sprintf("last=%12s calls=%4d %s %s\n", $cid_date, $cid_number, $_, $cid_name); + for ( sort keys %results ) { + my ( $cid_number, $cid_date, $cid_name ) = + $results{$_} =~ /(\S+) (.+) name=(.+)/; + $cid_name = $callerid_name_by_number{$_} + if $callerid_name_by_number{$_}; + $cid_date = + ( split( ',', $cid_date ) )[1]; # Drop leading time field + + # $results .= sprintf("%15s: %-15s calls=%3s last=%s\n %s\n", $_, $cid_name, $cid_number, $cid_date, $caller); + $results .= sprintf( "last=%12s calls=%4d %s %s\n", + $cid_date, $cid_number, $_, $cid_name ); } -# map {$results .= " $_: $results{$_}\n\n"} sort keys %results; - $results = "Results: $count2 out of $count1 records matched\n\n" . $results; + + # map {$results .= " $_: $results{$_}\n\n"} sort keys %results; + $results = + "Results: $count2 out of $count1 records matched\n\n" . $results; } else { - $results = "\nResults: No match found out of $count1 records searched\n"; + $results = + "\nResults: No match found out of $count1 records searched\n"; } - $list->delete('0.0', 'end'); - $list->insert('0.0', $results); + $list->delete( '0.0', 'end' ); + $list->insert( '0.0', $results ); } -sub sort_data { - my($class) = @_; - my $sort_by = $info{$class}{sort}; +sub sort_data { + my ($class) = @_; + my $sort_by = $info{$class}{sort}; $sort_by = 'time_date' unless $sort_by; - print "Sorting data for $class by $sort_by ... "; - my($data, $count); - undef $data; - $count = 0; - my $rec; - for $rec (sort {$calls{$class}{$b}{$sort_by} cmp $calls{$class}{$a}{$sort_by}} keys %{$calls{$class}}) { - $count++; - $data .= sprintf("%s %s %-12s %s\n", - $calls{$class}{$rec}{time_date}, - $calls{$class}{$rec}{line}, - $calls{$class}{$rec}{number}, - $calls{$class}{$rec}{name2}); - } - if ($parms{cgi}) { + print "Sorting data for $class by $sort_by ... "; + my ( $data, $count ); + undef $data; + $count = 0; + my $rec; + + for $rec ( + sort { $calls{$class}{$b}{$sort_by} cmp $calls{$class}{$a}{$sort_by} } + keys %{ $calls{$class} } + ) + { + $count++; + $data .= sprintf( + "%s %s %-12s %s\n", + $calls{$class}{$rec}{time_date}, $calls{$class}{$rec}{line}, + $calls{$class}{$rec}{number}, $calls{$class}{$rec}{name2} + ); + } + if ( $parms{cgi} ) { return $data; } else { - my $list = $info{$class}{window}; -# $list->configure(-state => 'normal'); - $list->delete('0.0', 'end'); - $list->insert('0.0', $data); -# $list->configure(-state => 'disabled'); # ... this disables the curser :( - $info{$class}{label2} = "$info{$class}{label} ($count entries)"; - print "done\n"; + my $list = $info{$class}{window}; + + # $list->configure(-state => 'normal'); + $list->delete( '0.0', 'end' ); + $list->insert( '0.0', $data ); + + # $list->configure(-state => 'disabled'); # ... this disables the curser :( + $info{$class}{label2} = "$info{$class}{label} ($count entries)"; + print "done\n"; } } - sub post_cgi_form { - print &startform(-name => 'form1'); + print &startform( -name => 'form1' ); + + print "\n"; - print "
\n"; -# print "
\n"; + # print "
\n"; print ""; &phone_list2('in'); @@ -549,21 +652,34 @@ sub post_cgi_form { &phone_list2('dbm'); print ""; - print "\n"; - print "\n"; + print "\n"; + print "\n"; print ""; print "
", "Incoming Call Logs

", &scrolling_list(-name=>'logs_in', -size => 10, -default => 1, - -values => \@members1, -multiple => 'true', - -onChange => "document.form1.submit()"), "

", "Outgoing Call Logs

", &scrolling_list(-name=>'logs_out', -size => 10, -default => 1, - -values => \@members2, -multiple => 'true', - -onChange => "document.form1.submit()"), "

", "Incoming Call Logs

", + &scrolling_list( + -name => 'logs_in', + -size => 10, + -default => 1, + -values => \@members1, + -multiple => 'true', + -onChange => "document.form1.submit()" + ), + "

", "Outgoing Call Logs

", + &scrolling_list( + -name => 'logs_out', + -size => 10, + -default => 1, + -values => \@members2, + -multiple => 'true', + -onChange => "document.form1.submit()" + ), + "

\n"; print &end_html; - -# print "

",&reset; -# print &submit('Action','Shout'); + # print "

",&reset; + # print &submit('Action','Shout'); print &endform; print "

\n"; print "
\n"; @@ -573,14 +689,27 @@ sub post_cgi_form { sub phone_list2 { my ($list) = @_; - print "\n
", "$info{$list}{label} Calls ($info{$list}{count} entries)
\n"; - print &radio_group(-name=>"sort_$list", -values=>['name', 'number', 'date'], -default=>$info{$list}{sort}, - -onClick => "document.form1.submit()"), "

\n"; - -# print "
", &sort_data($list), "
\n"; -# print &scrolling_list(-name=>"calls_$list", -size=>10, -values=> [split("\n", &sort_data($list))]), "\n"; - print &textarea(-name=>"calls_$list", -rows=>15, -columns=>60, -default=> &sort_data($list)), "\n"; -# -onFocus => "if (document.form1.calls_out.value != '') document.form1.submit()" ), "\n"; + print "\n
", + "$info{$list}{label} Calls ($info{$list}{count} entries)
\n"; + print &radio_group( + -name => "sort_$list", + -values => [ 'name', 'number', 'date' ], + -default => $info{$list}{sort}, + -onClick => "document.form1.submit()" + ), + "

\n"; + + # print "
", &sort_data($list), "
\n"; + # print &scrolling_list(-name=>"calls_$list", -size=>10, -values=> [split("\n", &sort_data($list))]), "\n"; + print &textarea( + -name => "calls_$list", + -rows => 15, + -columns => 60, + -default => &sort_data($list) + ), + "\n"; + + # -onFocus => "if (document.form1.calls_out.value != '') document.form1.submit()" ), "\n"; } diff --git a/bin/do_nothing b/bin/do_nothing index be52c5613..d8c56f3e3 100755 --- a/bin/do_nothing +++ b/bin/do_nothing @@ -3,11 +3,11 @@ # Call this if you don't want to do anything :) # # For example, say you want to debug code that parses html, but -# you do not want to retrieve the html, simply start the +# you do not want to retrieve the html, simply start the # Process_Item with a do_nothing override: # # $get_url = new Process_Item "get_url http://misterhouse.sf.net temp.html"; # start $get_url if said $normal_usage; # start $get_url 'do_nothing' if said $test_usage; -# &parse_html if done_now $get_url; +# &parse_html if done_now $get_url; diff --git a/bin/find_files b/bin/find_files index 6cae8bdc2..4b6d8daa0 100755 --- a/bin/find_files +++ b/bin/find_files @@ -16,18 +16,23 @@ Copyright 1998-2001 Bruce Winter use strict; -my($Pgm_Path, $Pgm_Name, $Version); +my ( $Pgm_Path, $Pgm_Name, $Version ); + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; } my %parms; use Getopt::Long; -if (!&GetOptions(\%parms, 'h', 'help', 'v', 'boxes=s', 'skip=s', 'dirs=s') or - !@ARGV or $parms{h} or $parms{help}) { - print<GetObject("WinMgmts:{impersonationLevel=impersonate}!//$box")) { - for my $share (Win32::OLE::in($WMI->InstancesOf('Win32_Share'))) { - next unless $share->{Type} == 0; # Look at shares only - next if $share->{Name} =~ /\$$/; # Ignore hidden shares + if ( + my $WMI = Win32::OLE->GetObject( + "WinMgmts:{impersonationLevel=impersonate}!//$box") + ) + { + for my $share ( Win32::OLE::in( $WMI->InstancesOf('Win32_Share') ) ) + { + next unless $share->{Type} == 0; # Look at shares only + next if $share->{Name} =~ /\$$/; # Ignore hidden shares push @shares, "//$box/$share->{Name}"; printf "%-8s Name: %s, Type: %s, Status: %s Path: %s\n", - $box, $share->{Name}, $share->{Type}, $share->{Status}, $share->{Path}; + $box, $share->{Name}, $share->{Type}, $share->{Status}, + $share->{Path}; } } } @@ -124,26 +135,25 @@ sub find_shares_wmi { } sub read_dir { - my($dir) = @_; + my ($dir) = @_; return if grep $dir =~ /$_/i, @skip; print " - Reading files in $dir\n" if $parms{v}; $counts{dir}++; - opendir(DIR, $dir) or do {print "Error in dir open: $!\n"; return}; + opendir( DIR, $dir ) or do { print "Error in dir open: $!\n"; return }; my @files = readdir DIR; close DIR; - for my $file (sort @files) { + for my $file ( sort @files ) { next if $file eq '.' or $file eq '..'; $file = "$dir/$file"; &read_dir($file), next if -d $file; $counts{file}++; - if ($file =~ /$search/i) { + if ( $file =~ /$search/i ) { $counts{found}++; push @found, $file; } } } - # # $Log: find_files,v $ diff --git a/bin/find_programs b/bin/find_programs index f400d8635..41cc5b013 100755 --- a/bin/find_programs +++ b/bin/find_programs @@ -43,18 +43,23 @@ Copyright 1998-2001 Bruce Winter use strict; -my($Pgm_Path, $Pgm_Name, $Version); +my ( $Pgm_Path, $Pgm_Name, $Version ); + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; } my %parms; use Getopt::Long; -if (!&GetOptions(\%parms, 'h', 'help', 'all') or - !@ARGV or $parms{h} or $parms{help}) { - print<GetObject("WinMgmts:{impersonationLevel=impersonate}!//$box")) { - for my $process (Win32::OLE::in($WMI->InstancesOf('Win32_Process'))) { + if ( + my $WMI = Win32::OLE->GetObject( + "WinMgmts:{impersonationLevel=impersonate}!//$box") + ) + { + for my $process ( Win32::OLE::in( $WMI->InstancesOf('Win32_Process') ) ) + { my $name = $process->{Name}; $count++; next if !$parms{all} and grep $name =~ /$_/i, @ignore_list; next if $find and $name !~ /$find/i; - $list .= sprintf " PID:%5d,%5d Pgm:%-15s Threads:%3s Mem:%6.2f,%6.2f Date: %s\n", - $process->{ProcessID}, $process->{ParentProcessID}, $process->{Name}, $process->{ThreadCount}, - $process->{WorkingSetSize}/10**6, $process->{PeakWorkingSetSize}/10**6, $process->{CreationDate}; + $list .= + sprintf + " PID:%5d,%5d Pgm:%-15s Threads:%3s Mem:%6.2f,%6.2f Date: %s\n", + $process->{ProcessID}, $process->{ParentProcessID}, + $process->{Name}, $process->{ThreadCount}, + $process->{WorkingSetSize} / 10**6, + $process->{PeakWorkingSetSize} / 10**6, $process->{CreationDate}; } } else { - print "WMI unable to connect to \\$box:" . Win32::OLE->LastError() . "\n"; + print "WMI unable to connect to \\$box:" + . Win32::OLE->LastError() . "\n"; } - return($count, $list); + return ( $count, $list ); } - # # $Log: find_programs,v $ # Revision 1.1 2001/05/28 21:22:46 winter diff --git a/bin/get_earthquakes b/bin/get_earthquakes index f45f69e23..501a92008 100755 --- a/bin/get_earthquakes +++ b/bin/get_earthquakes @@ -10,7 +10,7 @@ # Michael Stovenour www.stovenour.net # Change log: # - 01/22/2009 - Initial version based on original internet_earthquakes.pl -# common code script written by Tim Doyle and David Norwood +# common code script written by Tim Doyle and David Norwood # # This free software is licensed under the terms of the GNU public license. # @@ -20,22 +20,25 @@ #Threshold check marks the item for speech. Then "read" will speak all items # marked for speech and "get" will speak new items that are marked for speech. - use strict; -our ($Pgm_Path, $Pgm_Name); +our ( $Pgm_Path, $Pgm_Name ); + BEGIN { - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; } -my ($Version) = q$Revision: 398 $ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs +my ($Version) = + q$Revision: 398 $ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs use Getopt::Long; our %parms; -if (!&GetOptions(\%parms, "h", "help", "v", "d") or @ARGV or - ($parms{h} or $parms{help})) { - print< $DBM{$_}\n" } keys(%DBM)); - untie %DBM; - die "Dumpped the DBM file. Exiting!\n"; +if ( $parms{d} ) { + print map( {"$_ => $DBM{$_}\n"} keys(%DBM) ); + untie %DBM; + die "Dumpped the DBM file. Exiting!\n"; } unlink $f_cnss_merged_txt; my $getURLcmd = 'net_ftp -passive 1 -command get -server hazards.cr.usgs.gov '; $getURLcmd .= ' -user anonymous -password anonymous'; -system($getURLcmd . " -file $f_cnss_merged_txt -file_remote cnss/cnss_14.fing "); +system( $getURLcmd + . " -file $f_cnss_merged_txt -file_remote cnss/cnss_14.fing " ); -unless (open CNSS, $f_cnss_merged_txt) { +unless ( open CNSS, $f_cnss_merged_txt ) { die "$Pgm_Name: Failed to retrieve file from USGS\n"; } my @txtFile = ; close CNSS; -print("$Pgm_Name: read " . scalar(@txtFile) . " entries\n") if $parms{v}; +print( "$Pgm_Name: read " . scalar(@txtFile) . " entries\n" ) if $parms{v}; - -my ($event, @dbmEvent, $key, $line); +my ( $event, @dbmEvent, $key, $line ); my $keyNewest = ""; my %DBMsync; + # 0 1 2 3 4 5 6 7 8 9 #[gmt,lat,lon,depth,magnitude,source,location,distance,speak,spoken] #Key format -> gmt:lat:lon foreach $line (@txtFile) { - -# print("$Pgm_Name: considering event -> $line") if $parms{v}; - - if( $event = parse_quake($line)) { - $key = join(':', @{$event}[0..2]); - -# print "\$key: " . $key . "\n"; - - if ( !exists($DBM{$key}) ) { - #Entry is new so go ahead and calculate the distance; expensive - $event->[7] = sprintf "%d", calc_distance($latitude, $longitude, - $event->[1], $event->[2], $Earthquake_Units) + .5; - $event->[9] = 0; - } else { - #Retrieve the previously calculated distance and speak settings - @dbmEvent = split( $;, $DBM{$key} ); - $event->[7] = $dbmEvent[7]; - $event->[9] = $dbmEvent[9]; - } + # print("$Pgm_Name: considering event -> $line") if $parms{v}; - #Re-calculate the speak flag based on the configured magnitudes - # even for old entries. This allows the user to reconfigure the - # thresholds and have previously masked events spoken - $event->[8] = 0; - foreach my $distance (keys %Magnitude_thresholds) { - if ( $event->[7] <= $distance and $event->[4] >= $Magnitude_thresholds{$distance}) { - print("$Pgm_Name: found magnitude " . $event->[4] . " quake " - . $event->[7] . " $Earthquake_Units away\n") if $parms{v}; - print($line) if $parms{v}; - $event->[8] = 1; - last; - } - } + if ( $event = parse_quake($line) ) { + $key = join( ':', @{$event}[ 0 .. 2 ] ); - #Update %DBM and add to %DBMsync so it will not be purged - $DBM{$key} = join( $;, @{$event} ); - $DBMsync{$key} = 1; - -#print "\$event: " . Dumper( $event) . "\n"; - - #Store off the newest key for the image retrieval - # Only store images for events that will be displayed - #Not deterministic for multiple events in the same second - # but it doesn't fail - if( $Earthquake_Display eq "all" || $event->[8]) { - if( $keyNewest ne "" ) { - @dbmEvent = split( $;, $DBM{$keyNewest} ); - if( $event->[0] > $dbmEvent[0]) { - $keyNewest = $key; + # print "\$key: " . $key . "\n"; + + if ( !exists( $DBM{$key} ) ) { + + #Entry is new so go ahead and calculate the distance; expensive + $event->[7] = sprintf "%d", + calc_distance( $latitude, $longitude, + $event->[1], $event->[2], $Earthquake_Units ) + .5; + $event->[9] = 0; + } + else { + #Retrieve the previously calculated distance and speak settings + @dbmEvent = split( $;, $DBM{$key} ); + $event->[7] = $dbmEvent[7]; + $event->[9] = $dbmEvent[9]; + } + + #Re-calculate the speak flag based on the configured magnitudes + # even for old entries. This allows the user to reconfigure the + # thresholds and have previously masked events spoken + $event->[8] = 0; + foreach my $distance ( keys %Magnitude_thresholds ) { + if ( $event->[7] <= $distance + and $event->[4] >= $Magnitude_thresholds{$distance} ) + { + print( "$Pgm_Name: found magnitude " + . $event->[4] + . " quake " + . $event->[7] + . " $Earthquake_Units away\n" ) + if $parms{v}; + print($line) if $parms{v}; + $event->[8] = 1; + last; + } } - } else { - $keyNewest = $key; - } + + #Update %DBM and add to %DBMsync so it will not be purged + $DBM{$key} = join( $;, @{$event} ); + $DBMsync{$key} = 1; + + #print "\$event: " . Dumper( $event) . "\n"; + + #Store off the newest key for the image retrieval + # Only store images for events that will be displayed + #Not deterministic for multiple events in the same second + # but it doesn't fail + if ( $Earthquake_Display eq "all" || $event->[8] ) { + if ( $keyNewest ne "" ) { + @dbmEvent = split( $;, $DBM{$keyNewest} ); + if ( $event->[0] > $dbmEvent[0] ) { + $keyNewest = $key; + } + } + else { + $keyNewest = $key; + } + } + + # print "\$keyNewest: $keyNewest\n"; + } + else { + print("$Pgm_Name: Failed to parse\n$line") if $parms{v}; } -# print "\$keyNewest: $keyNewest\n"; - } else { - print("$Pgm_Name: Failed to parse\n$line") if $parms{v}; - } - -} #end while more lines +} #end while more lines #calculate the image file name for the first new entry # 0 1 2 3 4 5 6 7 8 9 #[gmt,lat,lon,depth,magnitude,source,location,distance,speak,spoken] -if($keyNewest ne "") { - @dbmEvent = split( $; , $DBM{$keyNewest}); - my $long_reso = abs(5 * round($dbmEvent[1]/5)) > 45 ? (abs(5 * round($dbmEvent[1]/5)) > 65 ? 20 : 10) : 5; - my $image = 'http://earthquake.usgs.gov/recenteqsww/Maps/10/' . $long_reso * round(($dbmEvent[2] < 0 ? 360 + $dbmEvent[2] : $dbmEvent[2])/$long_reso) . '_' . 5 * round($dbmEvent[1]/5) . '.gif'; - unlink $f_earthquakes_gif; - $getURLcmd = "get_url " . ($parms{v} ? "" : "-quiet"); - system($getURLcmd . " $image $f_earthquakes_gif"); +if ( $keyNewest ne "" ) { + @dbmEvent = split( $;, $DBM{$keyNewest} ); + my $long_reso = + abs( 5 * round( $dbmEvent[1] / 5 ) ) > 45 + ? ( abs( 5 * round( $dbmEvent[1] / 5 ) ) > 65 ? 20 : 10 ) + : 5; + my $image = + 'http://earthquake.usgs.gov/recenteqsww/Maps/10/' + . $long_reso * + round( + ( $dbmEvent[2] < 0 ? 360 + $dbmEvent[2] : $dbmEvent[2] ) / $long_reso ) + . '_' + . 5 * + round( $dbmEvent[1] / 5 ) . '.gif'; + unlink $f_earthquakes_gif; + $getURLcmd = "get_url " . ( $parms{v} ? "" : "-quiet" ); + system( $getURLcmd . " $image $f_earthquakes_gif" ); } #Purge entries not in %DBMsync -my @keysOld = grep{!exists($DBMsync{$_})} keys(%DBM); +my @keysOld = grep { !exists( $DBMsync{$_} ) } keys(%DBM); delete @DBM{@keysOld}; - #Create the old earthquakes.txt file optionally with only the matching magnitudes. -my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday); -my ($qnoso, $qeawe, $qmag, $qspeek); +my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday ); +my ( $qnoso, $qeawe, $qmag, $qspeek ); my @keysSpeak; -unless (open TXT, "> $f_earthquakes_txt") { - die "$Pgm_Name: Failed to retrieve file from USGS\n"; +unless ( open TXT, "> $f_earthquakes_txt" ) { + die "$Pgm_Name: Failed to retrieve file from USGS\n"; } -if( $Earthquake_Display eq "all") { - #make an array of all the keys - @keysSpeak = keys(%DBM); -} else { - #make an array of all the keys where speak is true - @keysSpeak = grep { @dbmEvent=split($;, $DBM{$_}); $dbmEvent[8]} keys(%DBM); - - my $units = $Earthquake_Units eq 'miles' ? "miles" : "km "; - print( TXT "List is filtered using the follwing:\n"); - print( TXT " Distance <= Magnitude >=\n"); - foreach my $distThresh (sort({$b <=> $a} keys(%Magnitude_thresholds))) { - my $magThresh = $Magnitude_thresholds{$distThresh}; - $distThresh = $distThresh > 20038 ? " Any" : sprintf("%5.0d", $distThresh); - $magThresh = $magThresh == 0 ? " Any" : sprintf("%4.1f", $magThresh); - print( TXT " $distThresh $units $magThresh\n"); - } - print( TXT "\n"); +if ( $Earthquake_Display eq "all" ) { + + #make an array of all the keys + @keysSpeak = keys(%DBM); +} +else { + #make an array of all the keys where speak is true + @keysSpeak = + grep { @dbmEvent = split( $;, $DBM{$_} ); $dbmEvent[8] } keys(%DBM); + + my $units = $Earthquake_Units eq 'miles' ? "miles" : "km "; + print( TXT "List is filtered using the follwing:\n" ); + print( TXT " Distance <= Magnitude >=\n" ); + foreach my $distThresh ( sort( { $b <=> $a } keys(%Magnitude_thresholds) ) ) + { + my $magThresh = $Magnitude_thresholds{$distThresh}; + $distThresh = + $distThresh > 20038 ? " Any" : sprintf( "%5.0d", $distThresh ); + $magThresh = $magThresh == 0 ? " Any" : sprintf( "%4.1f", $magThresh ); + print( TXT " $distThresh $units $magThresh\n" ); + } + print( TXT "\n" ); } -# Distance <= Magnitude >= +# Distance <= Magnitude >= # 99999 miles 5.5 # show anything anywhere over 5.5 # 500 miles 3.5 # show anything within 500 miles/km over 3.5 # 100 miles 0 # show anything within 100 miles/km any size - -print( TXT "The full Bulletin is available via the Internet at:\n"); -print( TXT "ftp://hazards.cr.usgs.gov/cnss/cnss_14.fing\n\n"); -print( TXT "Updated as of " . scalar(localtime()) . ".\n\n"); -print( TXT " DATE-(UTC)-TIME LAT LON DEP MAG COMMENTS\n"); -print( TXT "yyyy/mm/dd hh:mm:ss deg. deg. km\n"); +print( TXT "The full Bulletin is available via the Internet at:\n" ); +print( TXT "ftp://hazards.cr.usgs.gov/cnss/cnss_14.fing\n\n" ); +print( TXT "Updated as of " . scalar( localtime() ) . ".\n\n" ); +print( TXT " DATE-(UTC)-TIME LAT LON DEP MAG COMMENTS\n" ); +print( TXT "yyyy/mm/dd hh:mm:ss deg. deg. km\n" ); # 0 1 2 3 4 5 6 7 8 9 #[gmt,lat,lon,depth,magnitude,source,location,distance,speak,spoken] -foreach my $key (reverse(sort(@keysSpeak))) { - @dbmEvent = split($;, $DBM{$key}); - - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($dbmEvent[0]); - printf(TXT "%04d/%02d/%02d %02d:%02d:%02d ", - $year+1900, $mon+1, $mday, $hour, $min, $sec); - - $qnoso = $dbmEvent[1] < 0 ? "S" : "N"; - $qeawe = $dbmEvent[2] < 0 ? "W" : "E"; - $qmag = $dbmEvent[4] > 0 ? sprintf("%3.1fM", $dbmEvent[4]) : " "; - $qspeek = $dbmEvent[8] ? "S" : " "; - printf(TXT "%6.2f%s %6.2f%s %5.1f %s %s %s\n", - abs($dbmEvent[1]), $qnoso, abs($dbmEvent[2]), $qeawe, $dbmEvent[3], - $qmag, $qspeek, $dbmEvent[6]); +foreach my $key ( reverse( sort(@keysSpeak) ) ) { + @dbmEvent = split( $;, $DBM{$key} ); + + ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday ) = + gmtime( $dbmEvent[0] ); + printf( TXT "%04d/%02d/%02d %02d:%02d:%02d ", + $year + 1900, + $mon + 1, $mday, $hour, $min, $sec + ); + + $qnoso = $dbmEvent[1] < 0 ? "S" : "N"; + $qeawe = $dbmEvent[2] < 0 ? "W" : "E"; + $qmag = $dbmEvent[4] > 0 ? sprintf( "%3.1fM", $dbmEvent[4] ) : " "; + $qspeek = $dbmEvent[8] ? "S" : " "; + printf( TXT "%6.2f%s %6.2f%s %5.1f %s %s %s\n", + abs( $dbmEvent[1] ), + $qnoso, abs( $dbmEvent[2] ), + $qeawe, $dbmEvent[3], $qmag, $qspeek, $dbmEvent[6] + ); } close TXT; untie %DBM; exit; +sub parse_quake { + my ($line) = @_; + + # GMT lat lon depth mag source location + #2009/02/11 01:23:56 34.02N 117.24W 12.6 1.6 CI: GREATER LOS ANGELES AREA, CALIF. + #2009/01/04 21:57:49 33.98N 116.78W 16.7 1.5 CI: SOUTHERN CALIFORNIA + # + # 0 1 2 3 4 5 6 7 8 9 + #[gmt,lat,lon,depth,magnitude,source,location,distance,speak,spoken] + + if ( + my ( + $qdate, $qtime, $qlatd, $qnoso, $qlong, + $qeawe, $qdept, $qmagn, $qsrc, $qloca + ) + = $line =~ + m!^(.{10})\s(.{8})\s(.{6})([NS])\s(.{6})([EW])\s(.{5})\s(.{3})\s(.{7}):\s(.+)! + ) + { + + #convert timestamp to gmt + my ( $qyear, $qmnth, $qday ) = $qdate =~ m!(\S+)/(\S+)/(\S+)!; + my ( $qhour, $qminu, $qseco ) = $qtime =~ m!(\S+):(\S+):(\S+)!; + my $qgmt; + eval { + $qgmt = timegm( $qseco, $qminu, $qhour, $qday, $qmnth - 1, $qyear ); + }; + if ($@) { + print("$Pgm_Name: timegm() failed to parse date and time\n") + if $parms{v}; + return 0; #failed to parse + } + #Normalize lat and lon + $qlatd += 0; + $qlong += 0; + $qlatd *= -1 if ( $qnoso eq "S" ); + $qlong *= -1 if ( $qeawe eq "W" ); -sub parse_quake { - my ($line) = @_; + #Make sure the magnitued and depth are a number + $qdept += 0; + $qmagn += 0; -# GMT lat lon depth mag source location -#2009/02/11 01:23:56 34.02N 117.24W 12.6 1.6 CI: GREATER LOS ANGELES AREA, CALIF. -#2009/01/04 21:57:49 33.98N 116.78W 16.7 1.5 CI: SOUTHERN CALIFORNIA -# -# 0 1 2 3 4 5 6 7 8 9 -#[gmt,lat,lon,depth,magnitude,source,location,distance,speak,spoken] + #Trim leading and trailing spaces if any + $qsrc =~ s/^\s+//; + $qloca =~ s/^\s+//; + $qsrc =~ s/\s+$//; + $qloca =~ s/\s+$//; - if (my ($qdate, $qtime, $qlatd, $qnoso, $qlong, $qeawe, $qdept, $qmagn, $qsrc, $qloca) = - $line =~ m!^(.{10})\s(.{8})\s(.{6})([NS])\s(.{6})([EW])\s(.{5})\s(.{3})\s(.{7}):\s(.+)! ) { - - #convert timestamp to gmt - my ($qyear, $qmnth, $qday) = $qdate =~ m!(\S+)/(\S+)/(\S+)!; - my ($qhour, $qminu, $qseco) = $qtime =~ m!(\S+):(\S+):(\S+)!; - my $qgmt; - eval { - $qgmt = timegm($qseco,$qminu,$qhour,$qday,$qmnth-1,$qyear); - }; - if ($@) { - print("$Pgm_Name: timegm() failed to parse date and time\n") if $parms{v}; - return 0; #failed to parse + # 0 1 2 3 4 5 6 + return ( [ $qgmt, $qlatd, $qlong, $qdept, $qmagn, $qsrc, $qloca ] ); + } + else { + print("$Pgm_Name: Line does not match expected format\n") if $parms{v}; + return 0; } - - #Normalize lat and lon - $qlatd += 0; $qlong += 0; - $qlatd *= -1 if ( $qnoso eq "S" ); - $qlong *= -1 if ( $qeawe eq "W" ); - - #Make sure the magnitued and depth are a number - $qdept +=0; $qmagn +=0; - - #Trim leading and trailing spaces if any - $qsrc =~ s/^\s+//; $qloca =~ s/^\s+//; - $qsrc =~ s/\s+$//; $qloca =~ s/\s+$//; - - # 0 1 2 3 4 5 6 - return( [$qgmt, $qlatd, $qlong, $qdept, $qmagn, $qsrc, $qloca]); - } else { - print("$Pgm_Name: Line does not match expected format\n") if $parms{v}; - return 0; - } } - sub calc_distance { - my ($lat1, $lon1, $lat2, $lon2, $units) = @_; - my ($c, $d); - - $c = 57.3; # radian conversion factor - $lat1 /= $c; $lat2 /= $c; $lon1 /= $c; $lon2 /= $c; - - $d = 2*Math::Trig::asin( - sqrt((sin(($lat1-$lat2)/2))**2 - + cos($lat1)*cos($lat2)*(sin(($lon1-$lon2)/2))**2) - ); - - if ($units ne 'miles') { - return $d*6378; # convert to kilometers and return - } - return $d*(.5*7915.6); # convert to miles and return + my ( $lat1, $lon1, $lat2, $lon2, $units ) = @_; + my ( $c, $d ); + + $c = 57.3; # radian conversion factor + $lat1 /= $c; + $lat2 /= $c; + $lon1 /= $c; + $lon2 /= $c; + + $d = 2 * Math::Trig::asin( + sqrt( + ( sin( ( $lat1 - $lat2 ) / 2 ) )**2 + + cos($lat1) * cos($lat2) * ( sin( ( $lon1 - $lon2 ) / 2 ) )**2 + ) + ); + + if ( $units ne 'miles' ) { + return $d * 6378; # convert to kilometers and return + } + return $d * ( .5 * 7915.6 ); # convert to miles and return } diff --git a/bin/get_email b/bin/get_email index 172ca9067..703ccdf68 100755 --- a/bin/get_email +++ b/bin/get_email @@ -11,7 +11,7 @@ # http://misterhouse.net/mh/bin/get_email # Change log: # 03/26/99 Created. -# Notes: +# Notes: # check required modules in lib/imap_utils.pl # # This software is licensed under the terms of the GNU public license. @@ -19,26 +19,34 @@ # #--------------------------------------------------------------------------- - use strict; #package get_mail; # So we can do the faster 'do' from mh, and not mess it up. -my ($Pgm_Path, $Pgm_Name, $Version); -use vars '$Pgm_Root'; # So we can see it in eval var subs in read_parms +my ( $Pgm_Path, $Pgm_Name, $Version ); +use vars '$Pgm_Root'; # So we can see it in eval var subs in read_parms + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; $Pgm_Root = "$Pgm_Path/.."; - eval "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'"; # Use BEGIN eval to keep perl2exe happy + eval "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'" + ; # Use BEGIN eval to keep perl2exe happy } use Getopt::Long; use vars qw(%config_parms %config_parms_startup); -if (!&GetOptions(\%config_parms_startup, 'quiet', 'debug', 'h', 'help', 'net_mail_scan_age=s') or - @ARGV or $config_parms_startup{h} or $config_parms_startup{help}) { - print<Latest emails
]; + $summary = + qq[$time    Latest emails
]; my $wday = (localtime)[6]; - my $day = ('sun', 'mon', 'tue', 'wed', 'thu', 'fri', 'sat', 'sun')[$wday]; + my $day = ( 'sun', 'mon', 'tue', 'wed', 'thu', 'fri', 'sat', 'sun' )[$wday]; -# my $msgcnt_flag = 'Email:'; - my ($msgcnt_flag, $msg_latest); + # my $msgcnt_flag = 'Email:'; + my ( $msgcnt_flag, $msg_latest ); for my $account (@email_accounts) { - print "checking $email_type{$account} account=$account " unless $config_parms{quiet}; - - my $msgcnt; - my $msgsize; - my $msgptr; - my $msg_unread; - my $msgcnt_prev; - - if (lc $email_type{$account} eq "imap") { - eval "require 'imap_utils.pl'"; - if ($@) { - print "Error in loading imap_utils: $@\n"; - print "To use imap, you need check the dependancies\n"; - die; - } - print "\nAccessing IMAP account $account...\n" unless $config_parms{quiet}; - ($msgcnt, $msgsize, $msg_unread, $msgptr) = &get_imap(account => $account, - age => $config_parms{net_mail_scan_age}, - quiet => $config_parms{quiet}, - debug => $config_parms{debug}); - if ($msgcnt) { - $msg_inbox_total = $msgcnt; - print "There are $msgcnt mail messages for $account\n" unless $config_parms{quiet}; - } - - } else { - ($msgcnt, $msgsize) = &net_mail_stats(account => $account, debug => $config_parms{debug}); - - # If count is < last time, assume we have read previous messages and reset for next pass - # If count is > last time, read only new messages - $msgcnt_prev = @{$email_prev{$account}} if $email_prev{$account}; - if (defined $msgcnt and $msgcnt < $msgcnt_prev) { - delete $email_prev{$account}; - unlink("$config_parms{data_dir}/email/latest.html"); - $msgcnt = 0; - } elsif ($msgcnt > $msgcnt_prev) { - $msg_inbox_total = $msgcnt; - print "There are $msgcnt mail messages for $account\n" unless $config_parms{quiet}; - $msgptr = &net_mail_summary(account => $account, - first => 1, last => $msgcnt, - age => $config_parms{net_mail_scan_age}, - debug => $config_parms{debug}); - - # If you leave mail in the mailbox and use scan_age, we need to - # reset this to only report new msgs, not total msgs - $msg_unread = $msgcnt; - if ($config_parms{net_mail_scan_age}) { - $msg_unread = ($$msgptr{from_name}) ? @{$$msgptr{from_name}} : 0; - } - } - } - #print "Building HTML Code...\n" unless $config_parms{quiet}; - if ($msgsize) { - my $nice_size; - $nice_size = "($msgsize bytes)" if ($msgsize < 1024); - $nice_size = sprintf ("(%.2f kB)",$msgsize / 1024) if ($msgsize >= 1024); - $nice_size = sprintf ("(%.2f MB)",$msgsize / 1024 / 1024) if ($msgsize >= (1024 * 1024)); - $nice_size = sprintf ("(%.2f GB)",$msgsize / 1024 / 1024 / 1024) if ($msgsize >= (1024 * 1024 * 1024)); - $msgsize = $nice_size; - } - my $message_s = "s"; - $message_s = "" if ($msgcnt == 1); - $summary .= qq[   $msgcnt message$message_s ($msg_unread unread) $msgsize in ] . - qq[$account: $config_parms{"net_mail_${account}_address"}, $config_parms{"net_mail_${account}_user"}
\n]; - - if ($$msgptr{from_name}) { - my @list = @{$$msgptr{from_name}}; - - # Use a rule to modify name of sender - # Changing $name will modify @list ($name is an implicit alias). - my $cnt = -1; - for my $name (@list) { - $cnt++; - - my $subject = $$msgptr{subject}[$cnt]; - my $to = $$msgptr{to}[$cnt]; - my $cc = $$msgptr{cc}[$cnt]; - my $replyto = $$msgptr{replyto}[$cnt]; - my $sender = $$msgptr{sender}[$cnt]; - my $from = $$msgptr{from}[$cnt]; - my $number = $$msgptr{number}[$cnt]; - my $body = $$msgptr{body}[$cnt]; - - $to .= ", $cc" if $cc; - $from .= ", $sender" if $sender; - - # Delete attachements - # The g in gsm will do this without the while loop - -# print "dbx get_email body=$body.\n"; - - $body =~ s/Content-Disposition: attachment.+?filename=(.+?)^.+/Attachment deleted: $1/gsm; -# while ($body =~ m/Content-Disposition: attachment.+?filename=(.+?\").+?NextPart.+?\n/s) { -# $body =~ s/Content-Disposition: attachment.+?filename=(.+?\").+?NextPart.+?\n/Attachment removed: $1\n\n/sm; -# } - - - $name = &get_email_rule($name, $to, $subject, $from, $body) if $email_rule; - - $name = 'filtered' unless $name; - - next if $name =~ /no store/; # Do not index/store - - print "Reading text for subject=$subject\n" unless $config_parms{quiet}; - - # Scan/summarize email - # - .scan is deleted in code_dir/internet_mail.pl after scanning for commands - # - .html will be deleted (in get_email) only after email has been read - logit("$config_parms{data_dir}/get_email.scan", - "Msg: $number From:$$msgptr{from}[$cnt] To:$to Subject:$subject Body:$body"); -# print "dbx get_email s=$subject body=$body\n"; - - use HTML::Entities; # So we can encode stuff like - $to = encode_entities $to; - $replyto = encode_entities $replyto; - $from = encode_entities $from; - $subject = encode_entities $subject; - if ($body =~ /^(.*?)(.*)$/is) { - $body = "
$1
\n

\n$2"; -# $body = "

$body
"; # Try to bound bad/untermintated html tags ... doesn't help - } - else { - $body = encode_entities $body; - $body = "
$body
"; - } - - my $href = time . $cnt; # An arbitrary index - my $href_prev = $href - 1 unless $cnt == 0; - my $href_next = $href + 1 unless $cnt == $#list; - $href_prev = 'top' unless $href_prev; # No easy way to track prev href - - my $time_date = &time_date_stamp(14, time); - my $html; -# $html = 'Date: ' . &time_date_stamp($config_parms{time_format_log} , time) . "
\n"; -# $html = 'Date: ' . &time_date_stamp(14, time) . "
\n"; # Log format same as .scan logit - $html = "Previous , "; - $html .= "Next\n" if $href_next; - $html .= "
Date: $time_date
\n"; # Log format same as .scan logit - $html .= "To:$to
\nFrom: $name
\nReply to: $replyto
\nSubject:$subject
\n"; - $html .= "
$body

\n"; - - # Track the latest mail separately -# logit("$config_parms{data_dir}/email/latest.html", $html, 0); - $msg_latest .= $html; - - # Log by account and day of week - my $log = "$config_parms{data_dir}/email/${account}_${day}.shtml"; - my $logi= "$config_parms{data_dir}/email/${account}_${day}_index.html"; - unlink $log if time - (stat $log)[9] > 3600*24; # Reset if from last week - unless (-e $log) { - unlink $logi; - my $html2 = "\n"; - $html2 .= "\n"; - logit($logi, $html2, 0); - $html2 = qq[\n]; - $html2 .= qq[\n
MsgReceivedFromSubject
\n
\n]; - logit($log, $html2, 0); - } - - #if msgcnt_prev is undefined then the message numbers will never be right - #in that case, read in the last line to see what the last msg # was - my $lastline; - $lastline = file_tail($logi,1) unless (defined $msgcnt_prev); - - ($msgcnt_prev) = $lastline =~ /\\(\d+)\<\/td\>/ unless (defined $msgcnt_prev); - $msgcnt_prev = 0 unless (defined $msgcnt_prev); - my $msgcnt2 = sprintf ("%02d", $msgcnt_prev + $cnt + 1); - $html = "($msgcnt2) Back to Index , " . $html; - - logit($log, $html, 0); - - my $index = "$msgcnt2$time_date$name"; - $index .= "$subject\n"; - logit($logi, $index, 0); + print "checking $email_type{$account} account=$account " + unless $config_parms{quiet}; + + my $msgcnt; + my $msgsize; + my $msgptr; + my $msg_unread; + my $msgcnt_prev; + + if ( lc $email_type{$account} eq "imap" ) { + eval "require 'imap_utils.pl'"; + if ($@) { + print "Error in loading imap_utils: $@\n"; + print "To use imap, you need check the dependancies\n"; + die; + } + print "\nAccessing IMAP account $account...\n" + unless $config_parms{quiet}; + ( $msgcnt, $msgsize, $msg_unread, $msgptr ) = &get_imap( + account => $account, + age => $config_parms{net_mail_scan_age}, + quiet => $config_parms{quiet}, + debug => $config_parms{debug} + ); + if ($msgcnt) { + $msg_inbox_total = $msgcnt; + print "There are $msgcnt mail messages for $account\n" + unless $config_parms{quiet}; + } + + } + else { + ( $msgcnt, $msgsize ) = &net_mail_stats( + account => $account, + debug => $config_parms{debug} + ); + + # If count is < last time, assume we have read previous messages and reset for next pass + # If count is > last time, read only new messages + $msgcnt_prev = @{ $email_prev{$account} } if $email_prev{$account}; + if ( defined $msgcnt and $msgcnt < $msgcnt_prev ) { + delete $email_prev{$account}; + unlink("$config_parms{data_dir}/email/latest.html"); + $msgcnt = 0; + } + elsif ( $msgcnt > $msgcnt_prev ) { + $msg_inbox_total = $msgcnt; + print "There are $msgcnt mail messages for $account\n" + unless $config_parms{quiet}; + $msgptr = &net_mail_summary( + account => $account, + first => 1, + last => $msgcnt, + age => $config_parms{net_mail_scan_age}, + debug => $config_parms{debug} + ); + + # If you leave mail in the mailbox and use scan_age, we need to + # reset this to only report new msgs, not total msgs + $msg_unread = $msgcnt; + if ( $config_parms{net_mail_scan_age} ) { + $msg_unread = + ( $$msgptr{from_name} ) ? @{ $$msgptr{from_name} } : 0; } + } + } - # Add to previously read names - push(@{$email_prev{$account}}, @list); + #print "Building HTML Code...\n" unless $config_parms{quiet}; + if ($msgsize) { + my $nice_size; + $nice_size = "($msgsize bytes)" if ( $msgsize < 1024 ); + $nice_size = sprintf( "(%.2f kB)", $msgsize / 1024 ) + if ( $msgsize >= 1024 ); + $nice_size = sprintf( "(%.2f MB)", $msgsize / 1024 / 1024 ) + if ( $msgsize >= ( 1024 * 1024 ) ); + $nice_size = sprintf( "(%.2f GB)", $msgsize / 1024 / 1024 / 1024 ) + if ( $msgsize >= ( 1024 * 1024 * 1024 ) ); + $msgsize = $nice_size; + } + my $message_s = "s"; + $message_s = "" if ( $msgcnt == 1 ); + $summary .= + qq[   $msgcnt message$message_s ($msg_unread unread) $msgsize in ] + . qq[$account: $config_parms{"net_mail_${account}_address"}, $config_parms{"net_mail_${account}_user"}
\n]; + + if ( $$msgptr{from_name} ) { + my @list = @{ $$msgptr{from_name} }; + + # Use a rule to modify name of sender + # Changing $name will modify @list ($name is an implicit alias). + my $cnt = -1; + for my $name (@list) { + $cnt++; + + my $subject = $$msgptr{subject}[$cnt]; + my $to = $$msgptr{to}[$cnt]; + my $cc = $$msgptr{cc}[$cnt]; + my $replyto = $$msgptr{replyto}[$cnt]; + my $sender = $$msgptr{sender}[$cnt]; + my $from = $$msgptr{from}[$cnt]; + my $number = $$msgptr{number}[$cnt]; + my $body = $$msgptr{body}[$cnt]; + + $to .= ", $cc" if $cc; + $from .= ", $sender" if $sender; + + # Delete attachements + # The g in gsm will do this without the while loop + + # print "dbx get_email body=$body.\n"; + + $body =~ + s/Content-Disposition: attachment.+?filename=(.+?)^.+/Attachment deleted: $1/gsm; + + # while ($body =~ m/Content-Disposition: attachment.+?filename=(.+?\").+?NextPart.+?\n/s) { + # $body =~ s/Content-Disposition: attachment.+?filename=(.+?\").+?NextPart.+?\n/Attachment removed: $1\n\n/sm; + # } + + $name = &get_email_rule( $name, $to, $subject, $from, $body ) + if $email_rule; + + $name = 'filtered' unless $name; + + next if $name =~ /no store/; # Do not index/store + + print "Reading text for subject=$subject\n" + unless $config_parms{quiet}; + + # Scan/summarize email + # - .scan is deleted in code_dir/internet_mail.pl after scanning for commands + # - .html will be deleted (in get_email) only after email has been read + logit( "$config_parms{data_dir}/get_email.scan", + "Msg: $number From:$$msgptr{from}[$cnt] To:$to Subject:$subject Body:$body" + ); + + # print "dbx get_email s=$subject body=$body\n"; + + use HTML::Entities + ; # So we can encode stuff like + $to = encode_entities $to; + $replyto = encode_entities $replyto; + $from = encode_entities $from; + $subject = encode_entities $subject; + if ( $body =~ /^(.*?)(.*)$/is ) { + $body = "
$1
\n

\n$2"; + + # $body = "

$body
"; # Try to bound bad/untermintated html tags ... doesn't help + } + else { + $body = encode_entities $body; + $body = "
$body
"; + } - $results_new .= &make_name_list($account, @{$email_prev{$account}}); + my $href = time . $cnt; # An arbitrary index + my $href_prev = $href - 1 unless $cnt == 0; + my $href_next = $href + 1 unless $cnt == $#list; + $href_prev = 'top' + unless $href_prev; # No easy way to track prev href + + my $time_date = &time_date_stamp( 14, time ); + my $html; + + # $html = 'Date: ' . &time_date_stamp($config_parms{time_format_log} , time) . "
\n"; + # $html = 'Date: ' . &time_date_stamp(14, time) . "
\n"; # Log format same as .scan logit + $html = "Previous , "; + $html .= "Next\n" if $href_next; + $html .= "
Date: $time_date
\n" + ; # Log format same as .scan logit + $html .= + "To:$to
\nFrom: $name
\nReply to: $replyto
\nSubject:$subject
\n"; + $html .= "
$body

\n"; + + # Track the latest mail separately + # logit("$config_parms{data_dir}/email/latest.html", $html, 0); + $msg_latest .= $html; + + # Log by account and day of week + my $log = + "$config_parms{data_dir}/email/${account}_${day}.shtml"; + my $logi = + "$config_parms{data_dir}/email/${account}_${day}_index.html"; + unlink $log + if time - ( stat $log )[9] > + 3600 * 24; # Reset if from last week + unless ( -e $log ) { + unlink $logi; + my $html2 = + "\n"; + $html2 .= + "\n"; + logit( $logi, $html2, 0 ); + $html2 = + qq[\n]; + $html2 .= + qq[\n
MsgReceivedFromSubject
\n
\n]; + logit( $log, $html2, 0 ); + } + #if msgcnt_prev is undefined then the message numbers will never be right + #in that case, read in the last line to see what the last msg # was + my $lastline; + $lastline = file_tail( $logi, 1 ) + unless ( defined $msgcnt_prev ); + + ($msgcnt_prev) = $lastline =~ /\\(\d+)\<\/td\>/ + unless ( defined $msgcnt_prev ); + $msgcnt_prev = 0 unless ( defined $msgcnt_prev ); + my $msgcnt2 = sprintf( "%02d", $msgcnt_prev + $cnt + 1 ); + $html = + "($msgcnt2) Back to Index , " + . $html; + + logit( $log, $html, 0 ); + + my $index = + "$msgcnt2$time_date$name"; + $index .= "$subject\n"; + logit( $logi, $index, 0 ); } + + # Add to previously read names + push( @{ $email_prev{$account} }, @list ); + + $results_new .= + &make_name_list( $account, @{ $email_prev{$account} } ); + + } + #}? -#----- + #----- if ($msg_latest) { - # If new mail is age based, need to reset latest.html every time - unlink("$config_parms{data_dir}/email/latest.html") if $config_parms{net_mail_scan_age}; - logit("$config_parms{data_dir}/email/latest.html", $msg_latest, 0); + + # If new mail is age based, need to reset latest.html every time + unlink("$config_parms{data_dir}/email/latest.html") + if $config_parms{net_mail_scan_age}; + logit( "$config_parms{data_dir}/email/latest.html", $msg_latest, + 0 ); } -# $msgcnt_flag .= sprintf("%3d", ($config_parms{net_mail_scan_age})?$msg_inbox_total:$msgcnt); -# gmail can have thousands of messages, instead, just add a space... - $message_counts .= " " . ($config_parms{net_mail_scan_age}?$msg_inbox_total:$msgcnt); + # $msgcnt_flag .= sprintf("%3d", ($config_parms{net_mail_scan_age})?$msg_inbox_total:$msgcnt); + # gmail can have thousands of messages, instead, just add a space... + $message_counts .= " " + . ( $config_parms{net_mail_scan_age} ? $msg_inbox_total : $msgcnt ); + + my $temp = &make_name_list( $account, @{ $email_prev{$account} } ); + $results_unread .= $temp; - my $temp = &make_name_list($account, @{$email_prev{$account}}); - $results_unread .= $temp; - # Create html version with a link - $temp =~ s|^(.+) has |   $1 has |; + # Create html version with a link + $temp =~ + s|^(.+) has |   $1 has |; $results_unread2 .= $temp . "
" if $temp; - # Save parsed data, so we don't have to re-read next time - $email_file_data .= (join($;, $account, @{$email_prev{$account}})) . "\n" if - $email_prev{$account} and @{$email_prev{$account}}; + # Save parsed data, so we don't have to re-read next time + $email_file_data .= + ( join( $;, $account, @{ $email_prev{$account} } ) ) . "\n" + if $email_prev{$account} and @{ $email_prev{$account} }; } - &file_write("$config_parms{data_dir}/get_email.data", $email_file_data); - &file_write("$config_parms{data_dir}/get_email.txt", $results_new); - &file_write("$config_parms{data_dir}/get_email2.txt", $results_unread); - &file_write("$config_parms{data_dir}/get_email.flag", $message_counts); + &file_write( "$config_parms{data_dir}/get_email.data", $email_file_data ); + &file_write( "$config_parms{data_dir}/get_email.txt", $results_new ); + &file_write( "$config_parms{data_dir}/get_email2.txt", $results_unread ); + &file_write( "$config_parms{data_dir}/get_email.flag", $message_counts ); $results_unread =~ s/account /

Account /gs; $summary .= "$results_unread2"; - logit("$config_parms{data_dir}/email/summary.html", $summary, 0); + logit( "$config_parms{data_dir}/email/summary.html", $summary, 0 ); - unless ($config_parms{quiet}) { - print "\nNew\n", $results_new; + unless ( $config_parms{quiet} ) { + print "\nNew\n", $results_new; print "\nUnread\n", $results_unread; } } sub make_name_list { - my ($account, @list) = @_; + my ( $account, @list ) = @_; my $account2 = $account; - $account2 =~ tr/_/ /; # Make speakable + $account2 =~ tr/_/ /; # Make speakable - @list = grep !/^filtered/i, @list; # Delete blank names (filtered out from the above get_email_rule) + @list = grep !/^filtered/i, + @list; # Delete blank names (filtered out from the above get_email_rule) my $cnt = @list; return unless $cnt; + # Make fred@xyz.com a bit more pronouncable + # Naw, this gets put to a displayed file also, + # so lets leave it. Added .com et all to pronounceable_words.list + # for (@list) { + # $_ =~ s/\./ Dot /g ; # ...change "." to the word "Dot" + # $_ =~ s/\@/ At /g ; # ...change \@ to the word "At" + # } - # Make fred@xyz.com a bit more pronouncable - # Naw, this gets put to a displayed file also, - # so lets leave it. Added .com et all to pronounceable_words.list -# for (@list) { -# $_ =~ s/\./ Dot /g ; # ...change "." to the word "Dot" -# $_ =~ s/\@/ At /g ; # ...change \@ to the word "At" -# } + return ("$account2 has " + . plural( $cnt, 'new message' ) + . " from " + . &speakify_list(@list) + . ".\n" ); - return ("$account2 has " . plural($cnt, 'new message') . - " from " . &speakify_list(@list) . ".\n"); -# return ("Email account $account2 has " . plural($cnt, 'new email message') . + # return ("Email account $account2 has " . plural($cnt, 'new email message') . } - # # $Log: get_email,v $ # Revision 1.37 2004/11/22 22:57:17 winter diff --git a/bin/get_email_rule_example.pl b/bin/get_email_rule_example.pl index a36589a6e..f5e2045a4 100755 --- a/bin/get_email_rule_example.pl +++ b/bin/get_email_rule_example.pl @@ -1,18 +1,20 @@ - # Modify this rule for use with get_email - # Rename to get_email_rule.pl to enable - # - $from_full has the full email address, not just the name portion. +# Modify this rule for use with get_email +# Rename to get_email_rule.pl to enable +# - $from_full has the full email address, not just the name portion. sub get_email_rule { - my ($from, $to, $subject, $from_full) = @_; + my ( $from, $to, $subject, $from_full ) = @_; $from = 'The Mister House guys' if $to =~ /[mh]/; $from = 'The perl guys' if $to =~ /Perl-Win32-Users/; $from = 'The phone guys' if $to =~ /ktx/ or $subject =~ /kx-t/i; - $from = 'junk mail' if $from =~ /\S+[0-9]{3,}/; # If we get a joe#### type address, assume it is junk mail. - return if $from =~ /X10 Newsletter/; + $from = 'junk mail' + if $from =~ /\S+[0-9]{3,}/ + ; # If we get a joe#### type address, assume it is junk mail. + return if $from =~ /X10 Newsletter/; -# These are not needed if using the MS TTS engine (it pronounces fred@placed.com ok) -# $from =~ s/\./ Dot /g ; # ...change "." to the word "Dot" -# $from =~ s/\@/ At /g ; # ...change \@ to the word "At" + # These are not needed if using the MS TTS engine (it pronounces fred@placed.com ok) + # $from =~ s/\./ Dot /g ; # ...change "." to the word "Dot" + # $from =~ s/\@/ At /g ; # ...change \@ to the word "At" return $from; } diff --git a/bin/get_finger b/bin/get_finger index 26c30ab1b..b154e13e2 100755 --- a/bin/get_finger +++ b/bin/get_finger @@ -3,22 +3,25 @@ use strict; use IO::Socket; -unless (@ARGV == 1 or @ARGV == 2) { die "usage: $0 user\@host [outfile]" } -my ($user,$host) = split "@", shift; +unless ( @ARGV == 1 or @ARGV == 2 ) { die "usage: $0 user\@host [outfile]" } +my ( $user, $host ) = split "@", shift; my $outfile = shift || ''; -my $EOL = "\015\012"; -my $BLANK = $EOL x 2; -my $remote = IO::Socket::INET->new( Proto => "tcp", - PeerAddr => $host, - PeerPort => "finger(79)", - ); +my $EOL = "\015\012"; +my $BLANK = $EOL x 2; +my $remote = IO::Socket::INET->new( + Proto => "tcp", + PeerAddr => $host, + PeerPort => "finger(79)", +); unless ($remote) { die "cannot connect to finger on $host" } $remote->autoflush(1); print $remote $user . $BLANK; + if ($outfile) { - open(OUT, ">$outfile") || die "cannot open output file $outfile"; - while ( <$remote> ) { print OUT} -} else { - while ( <$remote> ) { print } + open( OUT, ">$outfile" ) || die "cannot open output file $outfile"; + while (<$remote>) { print OUT} +} +else { + while (<$remote>) { print } } close $remote; diff --git a/bin/get_mp3_data b/bin/get_mp3_data index 37cf4fd40..8891f9f24 100755 --- a/bin/get_mp3_data +++ b/bin/get_mp3_data @@ -4,17 +4,23 @@ use strict; use IO::File; -my($Pgm_Path, $Pgm_Name, $Version); +my ( $Pgm_Path, $Pgm_Name, $Version ); + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.+)\.?/; + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.+)\.?/; ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; } my %parms; use Getopt::Long; -if (!&GetOptions(\%parms, "h", "help", "dbm=s") or !@ARGV or $parms{h} or $parms{help}) { - print< 0) { - if ($$remainder == 0) { - #Find out if the stream is an Ogg stream and is version 0. - return if sysread($fh, $buf, 5) != 5; - return if unpack('H10', $buf) ne '4f67675300'; - #Skip the next 21 bytes. - return if sysread($fh, $buf, 21) != 21; - #Read the number of page segments. - return if sysread($fh, $buf, 1) != 1; - my $segments = ord($buf); - #Read the segment table. - while ($segments > 0) { - return if sysread($fh, $buf, 1) != 1; - $$remainder += ord($buf); - $segments--; - } - } - my $size = $bytes; - $size = $$remainder if $$remainder < $bytes; - $bytes -= $size; - return if sysread($fh, $buf, $size) != $size; - $$remainder -= $size; - $retval .= $buf; + + #Accepts three parameters. The first is an open file handle to an Ogg stream. + #The second is a reference to a variable where temporary data can be stored. + #This variable should be initialized to zero by the calling routine. + #The third is the number of bytes to return. + #The Ogg encapulation is removed from the stream. + #Returns nothing if there is an error, such as EOF. + my ( $fh, $remainder, $bytes ) = @_; + my ( $buf, $retval ); + while ( $bytes > 0 ) { + if ( $$remainder == 0 ) { + + #Find out if the stream is an Ogg stream and is version 0. + return if sysread( $fh, $buf, 5 ) != 5; + return if unpack( 'H10', $buf ) ne '4f67675300'; + + #Skip the next 21 bytes. + return if sysread( $fh, $buf, 21 ) != 21; + + #Read the number of page segments. + return if sysread( $fh, $buf, 1 ) != 1; + my $segments = ord($buf); + + #Read the segment table. + while ( $segments > 0 ) { + return if sysread( $fh, $buf, 1 ) != 1; + $$remainder += ord($buf); + $segments--; + } + } + my $size = $bytes; + $size = $$remainder if $$remainder < $bytes; + $bytes -= $size; + return if sysread( $fh, $buf, $size ) != $size; + $$remainder -= $size; + $retval .= $buf; } return $retval; } sub GetOggInfo ($) { -#Accepts a pathname as a parameter. -#Returns comments as UTF-8 encoded strings in a hash. -#Returns an empty hash if there are any errors. -#All comment field names are converted to uppercase. -#Uses IO::File. - my %comments=(); - my $filename=shift; + + #Accepts a pathname as a parameter. + #Returns comments as UTF-8 encoded strings in a hash. + #Returns an empty hash if there are any errors. + #All comment field names are converted to uppercase. + #Uses IO::File. + my %comments = (); + my $filename = shift; + #The file handle closes automatically when $fh goes out of scope. - my $fh = new IO::File; + my $fh = new IO::File; my $temp = 0; - my ($len, $listlength, $pos, $buf); + my ( $len, $listlength, $pos, $buf ); + #Find out if the file exists and is readable. Then open it. return if !-r $filename or !-f _; - return if !open($fh, $filename); + return if !open( $fh, $filename ); binmode($fh); + #Find out if the Ogg Stream uses Vorbis version 0 encoding. - return if unpack('H22', OggRead($fh, \$temp, 11)) ne '01766f7262697300000000'; + return + if unpack( 'H22', OggRead( $fh, \$temp, 11 ) ) ne + '01766f7262697300000000'; + #Skip the next 18 bytes of the identification header. - $buf = OggRead($fh, \$temp, 18); + $buf = OggRead( $fh, \$temp, 18 ); return if !defined $buf; + #Check the framing bit. - return if unpack('b1', OggRead($fh, \$temp, 1)) ne '1'; + return if unpack( 'b1', OggRead( $fh, \$temp, 1 ) ) ne '1'; + #Find out if there is a comment packet. - return if unpack('H14', OggRead($fh, \$temp, 7)) ne '03766f72626973'; + return if unpack( 'H14', OggRead( $fh, \$temp, 7 ) ) ne '03766f72626973'; + #Read the vendor string. - $len = unpack('I', OggRead($fh, \$temp, 4)); + $len = unpack( 'I', OggRead( $fh, \$temp, 4 ) ); return if !defined $len; - $buf = OggRead($fh, \$temp, $len); + $buf = OggRead( $fh, \$temp, $len ); return if !defined $buf; $comments{VENDOR} = $buf; + #Read the user comment list length. - $listlength = unpack('I', OggRead($fh, \$temp, 4)); + $listlength = unpack( 'I', OggRead( $fh, \$temp, 4 ) ); return if !defined $listlength; + #Read the user comments. - while ($listlength > 0) { - $len = unpack('I', OggRead($fh, \$temp, 4)); - return if !defined $len; - $buf = OggRead($fh, \$temp, $len); - return if !defined $buf; - $pos = index $buf, '='; - $comments{uc(substr($buf, 0, $pos))} = substr($buf, $pos + 1); - $listlength--; + while ( $listlength > 0 ) { + $len = unpack( 'I', OggRead( $fh, \$temp, 4 ) ); + return if !defined $len; + $buf = OggRead( $fh, \$temp, $len ); + return if !defined $buf; + $pos = index $buf, '='; + $comments{ uc( substr( $buf, 0, $pos ) ) } = substr( $buf, $pos + 1 ); + $listlength--; } + #Error check - return if unpack('b1', OggRead($fh, \$temp, 1)) ne '1'; + return if unpack( 'b1', OggRead( $fh, \$temp, 1 ) ) ne '1'; + #Return the user comments. return %comments; } sub read_mp3_dir { - my($dir) = @_; + my ($dir) = @_; my $buffer; - $dir =~ s|[/\\]$||; # Drop trailing / or \ + $dir =~ s|[/\\]$||; # Drop trailing / or \ print " - Reading files in $dir\n"; $counts{dir}++; - opendir(MP3DIR, $dir) or do {print "Error in dir open: $!\n"; return}; - my @files = readdir MP3DIR; # print "db files=@files\n"; + opendir( MP3DIR, $dir ) or do { print "Error in dir open: $!\n"; return }; + my @files = readdir MP3DIR; # print "db files=@files\n"; close MP3DIR; - my @mp3_genres = ('Blues', 'Classic Rock', 'Country', 'Dance', 'Disco', - 'Funk', 'Grunge', 'Hip-Hop', 'Jazz', 'Metal', 'New Age', 'Oldies', 'Other', - 'Pop', 'R&B', 'Rap', 'Reggae', 'Rock', 'Techno', 'Industrial', - 'Alternative', 'Ska', 'Death Metal', 'Pranks', 'Soundtrack', 'Euro-Techno', - 'Ambient', 'Trip-Hop', 'Vocal', 'Jazz+Funk', 'Fusion', 'Trance', - 'Classical', 'Instrumental', 'Acid', 'House', 'Game', 'Sound Clip', - 'Gospel', 'Noise', 'Alt. Rock', 'Bass', 'Soul', 'Punk', 'Space', - 'Meditative', 'Instrumental Pop', 'Instrumental Rock', 'Ethnic', 'Gothic', - 'Darkwave', 'Techno-Industrial', 'Electronic', 'Pop-Folk', 'Eurodance', - 'Dream', 'Southern Rock', 'Comedy', 'Cult', 'Gangsta Rap', 'Top 40', - 'Christian Rap', 'Pop/Funk', 'Jungle', 'Native American', 'Cabaret', - 'New Wave', 'Psychedelic', 'Rave', 'Showtunes', 'Trailer', 'Lo-Fi', - 'Tribal', 'Acid Punk', 'Acid Jazz', 'Polka', 'Retro', 'Musical', - 'Rock & Roll', 'Hard Rock', 'Folk', 'Folk/Rock', 'National Folk', 'Swing', - 'Fast-Fusion', 'Bebob', 'Latin', 'Revival', 'Celtic', 'Bluegrass', - 'Avantgarde', 'Gothic Rock', 'Progressive Rock', 'Psychedelic Rock', - 'Symphonic Rock', 'Slow Rock', 'Big Band', 'Chorus', 'Easy Listening', - 'Acoustic', 'Humour', 'Speech', 'Chanson', 'Opera', 'Chamber Music', - 'Sonata', 'Symphony', 'Booty Bass', 'Primus', 'Porn Groove', 'Satire', - 'Slow Jam', 'Club', 'Tango', 'Samba', 'Folklore', 'Ballad', 'Power Ballad', - 'Rhythmic Soul', 'Freestyle', 'Duet', 'Punk Rock', 'Drum Solo', - 'A Cappella', 'Euro-House', 'Dance Hall', 'Goa', 'Drum & Bass', - 'Club-House', 'Hardcore', 'Terror', 'Indie', 'BritPop', 'Negerpunk', - 'Polsk Punk', 'Beat', 'Christian Gangsta Rap', 'Heavy Metal', - 'Black Metal', 'Crossover', 'Contemporary Christian', 'Christian Rock', - 'Merengue', 'Salsa', 'Thrash Metal', 'Anime', 'JPop', 'Synthpop'); - - for my $file (sort @files) { - next if ($file =~ /^\./); + my @mp3_genres = ( + 'Blues', 'Classic Rock', + 'Country', 'Dance', + 'Disco', 'Funk', + 'Grunge', 'Hip-Hop', + 'Jazz', 'Metal', + 'New Age', 'Oldies', + 'Other', 'Pop', + 'R&B', 'Rap', + 'Reggae', 'Rock', + 'Techno', 'Industrial', + 'Alternative', 'Ska', + 'Death Metal', 'Pranks', + 'Soundtrack', 'Euro-Techno', + 'Ambient', 'Trip-Hop', + 'Vocal', 'Jazz+Funk', + 'Fusion', 'Trance', + 'Classical', 'Instrumental', + 'Acid', 'House', + 'Game', 'Sound Clip', + 'Gospel', 'Noise', + 'Alt. Rock', 'Bass', + 'Soul', 'Punk', + 'Space', 'Meditative', + 'Instrumental Pop', 'Instrumental Rock', + 'Ethnic', 'Gothic', + 'Darkwave', 'Techno-Industrial', + 'Electronic', 'Pop-Folk', + 'Eurodance', 'Dream', + 'Southern Rock', 'Comedy', + 'Cult', 'Gangsta Rap', + 'Top 40', 'Christian Rap', + 'Pop/Funk', 'Jungle', + 'Native American', 'Cabaret', + 'New Wave', 'Psychedelic', + 'Rave', 'Showtunes', + 'Trailer', 'Lo-Fi', + 'Tribal', 'Acid Punk', + 'Acid Jazz', 'Polka', + 'Retro', 'Musical', + 'Rock & Roll', 'Hard Rock', + 'Folk', 'Folk/Rock', + 'National Folk', 'Swing', + 'Fast-Fusion', 'Bebob', + 'Latin', 'Revival', + 'Celtic', 'Bluegrass', + 'Avantgarde', 'Gothic Rock', + 'Progressive Rock', 'Psychedelic Rock', + 'Symphonic Rock', 'Slow Rock', + 'Big Band', 'Chorus', + 'Easy Listening', 'Acoustic', + 'Humour', 'Speech', + 'Chanson', 'Opera', + 'Chamber Music', 'Sonata', + 'Symphony', 'Booty Bass', + 'Primus', 'Porn Groove', + 'Satire', 'Slow Jam', + 'Club', 'Tango', + 'Samba', 'Folklore', + 'Ballad', 'Power Ballad', + 'Rhythmic Soul', 'Freestyle', + 'Duet', 'Punk Rock', + 'Drum Solo', 'A Cappella', + 'Euro-House', 'Dance Hall', + 'Goa', 'Drum & Bass', + 'Club-House', 'Hardcore', + 'Terror', 'Indie', + 'BritPop', 'Negerpunk', + 'Polsk Punk', 'Beat', + 'Christian Gangsta Rap', 'Heavy Metal', + 'Black Metal', 'Crossover', + 'Contemporary Christian', 'Christian Rock', + 'Merengue', 'Salsa', + 'Thrash Metal', 'Anime', + 'JPop', 'Synthpop' + ); + + for my $file ( sort @files ) { + next if ( $file =~ /^\./ ); $file = "$dir/$file"; &read_mp3_dir($file), next if -d $file; -# next if $file eq '.' or $file eq '..' or $file !~ /\.mp3$/i; + + # next if $file eq '.' or $file eq '..' or $file !~ /\.mp3$/i; $counts{file}++; - open(MP3FILE, $file) or print "Error in in file open: $!\n"; - if (open(MP3FILE, $file)) { + open( MP3FILE, $file ) or print "Error in in file open: $!\n"; + if ( open( MP3FILE, $file ) ) { seek MP3FILE, -128, 2; read MP3FILE, $buffer, 128; close MP3FILE; - my @tag_data = unpack('A3A30A30A30A4A30C1', $buffer); - my $is_mp3 = 0; - if ('TAG' eq shift @tag_data) { + my @tag_data = unpack( 'A3A30A30A30A4A30C1', $buffer ); + my $is_mp3 = 0; + if ( 'TAG' eq shift @tag_data ) { $counts{tag}++; - $is_mp3 = 1; - } else { - my %ogg_data = GetOggInfo($file); - if (scalar %ogg_data) { - $counts{tag}++; - $tag_data[0] = $ogg_data{TITLE}; - $tag_data[1] = $ogg_data{ARTIST}; - $tag_data[2] = $ogg_data{ALBUM}; - if (defined $ogg_data{YEAR}) { - $tag_data[3] = $ogg_data{YEAR}; - } else { - $tag_data[3] = $ogg_data{DATE}; - } - $tag_data[4] = $ogg_data{COMMENT}; - $tag_data[5] = $ogg_data{GENRE}; - } else { - undef @tag_data; - } + $is_mp3 = 1; + } + else { + my %ogg_data = GetOggInfo($file); + if ( scalar %ogg_data ) { + $counts{tag}++; + $tag_data[0] = $ogg_data{TITLE}; + $tag_data[1] = $ogg_data{ARTIST}; + $tag_data[2] = $ogg_data{ALBUM}; + if ( defined $ogg_data{YEAR} ) { + $tag_data[3] = $ogg_data{YEAR}; + } + else { + $tag_data[3] = $ogg_data{DATE}; + } + $tag_data[4] = $ogg_data{COMMENT}; + $tag_data[5] = $ogg_data{GENRE}; + } + else { + undef @tag_data; + } } - if (!$is_mp3) { - #stored in artist, album subdirectories with "Music Now" song index prefix - if ($file =~ /\/(.*?)\/(.*?)\/\d\d\d\x20(.*).wma/i) { - $tag_data[0] = $3; - $tag_data[2] = $2; - $tag_data[1] = $1; - $counts{tag}++; - } - elsif ($file =~ /\/(.*?)\/(.*?)\/\d\d\d-(.*).wma/i) { - $tag_data[0] = $3; - $tag_data[2] = $2; - $tag_data[1] = $1; - $counts{tag}++; - } #stored in root as artist - song (Napster does this) - elsif ($file =~ /\/(.*?)\x20-\x20(.*).wma/i) { - $tag_data[0] = $2; $tag_data[1] = $1; - $counts{tag}++; - } - } - - for my $i (0 .. 5) { - if ($i == 5 && $is_mp3) { - $tag_data[$i] = $mp3_genres[$tag_data[$i]] if defined $tag_data[$i]; + if ( !$is_mp3 ) { + + #stored in artist, album subdirectories with "Music Now" song index prefix + if ( $file =~ /\/(.*?)\/(.*?)\/\d\d\d\x20(.*).wma/i ) { + $tag_data[0] = $3; + $tag_data[2] = $2; + $tag_data[1] = $1; + $counts{tag}++; + } + elsif ( $file =~ /\/(.*?)\/(.*?)\/\d\d\d-(.*).wma/i ) { + $tag_data[0] = $3; + $tag_data[2] = $2; + $tag_data[1] = $1; + $counts{tag}++; + } #stored in root as artist - song (Napster does this) + elsif ( $file =~ /\/(.*?)\x20-\x20(.*).wma/i ) { + $tag_data[0] = $2; + $tag_data[1] = $1; + $counts{tag}++; + } + } + + for my $i ( 0 .. 5 ) { + if ( $i == 5 && $is_mp3 ) { + $tag_data[$i] = $mp3_genres[ $tag_data[$i] ] + if defined $tag_data[$i]; } - $tag_data[$i] =~ tr/\x20-\x7e//cd; # Drop non-ascii characters + $tag_data[$i] =~ tr/\x20-\x7e//cd; # Drop non-ascii characters $tag_data[$i] =~ s/^\s+//; $tag_data[$i] =~ s/\s+$//; - if ($i == 1) { - if ($tag_data[$i] =~ s/^The\s+//) { - # Move "The" to the end... - $tag_data[$i] .= ', The'; - } - } - push @{$data[$i]}, $tag_data[$i]; + if ( $i == 1 ) { + if ( $tag_data[$i] =~ s/^The\s+// ) { + + # Move "The" to the end... + $tag_data[$i] .= ', The'; + } + } + push @{ $data[$i] }, $tag_data[$i]; $counts{$i}++ if $tag_data[$i]; } - $file =~ s|\\|/|g; - push @{$data[6]}, $file; + $file =~ s|\\|/|g; + push @{ $data[6] }, $file; } } } - # # $Log: get_mp3_data,v $ # Revision 1.8 2005/10/02 17:24:45 winter diff --git a/bin/get_tv_grid b/bin/get_tv_grid index e835c1596..1d1922359 100755 --- a/bin/get_tv_grid +++ b/bin/get_tv_grid @@ -39,67 +39,86 @@ use strict; #====================================================================== # Version info #====================================================================== -my($Pgm_Path, $Pgm_Name, $Version); +my ( $Pgm_Path, $Pgm_Name, $Version ); + BEGIN { - ($Version) = q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs - ($Pgm_Path, $Pgm_Name) = $0 =~ /(.*)[\\\/](.*)\.?/; - ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; - eval "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'"; # So perl2exe works + ($Version) = + q$Revision$ =~ /: (\S+)/; # Note: revision number is auto-updated by cvs + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.*)\.?/; + ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; + eval + "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'"; # So perl2exe works } require "RedirAgent.pm"; + #require "SMSAgent.pm"; -require 'handy_utilities.pl'; # For read_mh_opts -require 'handy_net_utilities.pl'; # For net_mail_send <-- causes probs in perl 5.6.1 with -w flag! +require 'handy_utilities.pl'; # For read_mh_opts +require 'handy_net_utilities.pl' + ; # For net_mail_send <-- causes probs in perl 5.6.1 with -w flag! use Getopt::Long; use LWP::Simple; use LWP::UserAgent; use HTTP::Cookies; use HTTP::Request::Common; -use vars '%config_parms'; # Not a my, as called from handy_net_utils - +use vars '%config_parms'; # Not a my, as called from handy_net_utils #====================================================================== # Variable declarations and other init #====================================================================== # Globals # -my ( %parms, $didLogIn, $infile, $outfile, %channels_skip, %channels_keep, $channel_data ); -my ($url, $ua, $cookie_jar, $req_get1, $req_get2, $req_post, $logged_in); -my (@hours, %providers, @uas); -my ($dbm_file, $dbm_file2); -my (%DBM, %DBM2); +my ( %parms, $didLogIn, $infile, $outfile, %channels_skip, %channels_keep, + $channel_data ); +my ( $url, $ua, $cookie_jar, $req_get1, $req_get2, $req_post, $logged_in ); +my ( @hours, %providers, @uas ); +my ( $dbm_file, $dbm_file2 ); +my ( %DBM, %DBM2 ); %channels_skip = (); %channels_keep = (); -$url = 'http://tvlistings2.zap2it.com/'; +$url = 'http://tvlistings2.zap2it.com/'; + #$url = 'http://tvlistings.zap2it.com/'; -$ua = new RedirAgent(); -#$ua = new SMSAgent(); +$ua = new RedirAgent(); +#$ua = new SMSAgent(); #====================================================================== # Temporary Debug variables #====================================================================== -my $dbgSubmitRequest = 1; # Set to 0 to turn off URL requests +my $dbgSubmitRequest = 1; # Set to 0 to turn off URL requests #====================================================================== # Check invocation options, and print usage message if necessary #====================================================================== -if (!&GetOptions(\%parms, "h", "help", "infile=s", "outfile=s", "outdir=s", - "reget", "redo", "db=s", "name=s", "preserveRaw", - "keep=s", "skip=s", "channel_max=s", "channel_min=s", - "zip:s", "debug", "label=s", "keep_old", "mail_to=s", - "provider:s", "provider_name:s", "get_providers", - "mail_server=s", "mail_baseref=s", - "purge=s", "mail_baseref=s", - "include_footer", - "days=s", "day=s", "hour=s", "tableChannels=s", "timebars=s") or @ARGV or - ($parms{h} or $parms{help})) +if ( + !&GetOptions( + \%parms, "h", + "help", "infile=s", + "outfile=s", "outdir=s", + "reget", "redo", + "db=s", "name=s", + "preserveRaw", "keep=s", + "skip=s", "channel_max=s", + "channel_min=s", "zip:s", + "debug", "label=s", + "keep_old", "mail_to=s", + "provider:s", "provider_name:s", + "get_providers", "mail_server=s", + "mail_baseref=s", "purge=s", + "mail_baseref=s", "include_footer", + "days=s", "day=s", + "hour=s", "tableChannels=s", + "timebars=s" + ) + or @ARGV + or ( $parms{h} or $parms{help} ) + ) { - print<Charter Communications - Rochester eof - exit; + exit; } #====================================================================== @@ -188,149 +207,152 @@ eof # $month = month #, like 1, 3, 12, etc. # $year = 4 digit year, like 1984, 2002... #====================================================================== -sub days_from_now -{ - #print "days_from_now: Incoming: @_ \n"; - my ($day_time, $days) = @_; - my $day_time2 = $day_time + $days * 60 * 60 * 24; - my ($day, $month, $year, $down) = (localtime($day_time2))[3,4,5,6]; - my $dow = (qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday))[$down]; - - $month++; - $year += 1900; - $day = sprintf("%02d", $day); - #print "days_from_now: Returning $day - $month - $year \n"; - return ($dow, $down, $day, $month, $year); -} +sub days_from_now { + #print "days_from_now: Incoming: @_ \n"; + my ( $day_time, $days ) = @_; + my $day_time2 = $day_time + $days * 60 * 60 * 24; + my ( $day, $month, $year, $down ) = ( localtime($day_time2) )[ 3, 4, 5, 6 ]; + my $dow = + (qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday))[$down]; + $month++; + $year += 1900; + $day = sprintf( "%02d", $day ); + #print "days_from_now: Returning $day - $month - $year \n"; + return ( $dow, $down, $day, $month, $year ); +} #====================================================================== # SUB: min_to_hour #====================================================================== -sub min_to_hour -{ - my ($min) = @_; - my $hour = int($min / 60); - $min = $min - $hour * 60; - return sprintf("%d:%02d", $hour, $min); +sub min_to_hour { + my ($min) = @_; + my $hour = int( $min / 60 ); + $min = $min - $hour * 60; + return sprintf( "%d:%02d", $hour, $min ); } - #====================================================================== # SUB: setup # Process invocation parameters prior to doing any real work #====================================================================== -sub setup -{ - &main::read_mh_opts(\%config_parms, $Pgm_Path); - - #------------------------------------------------------------ - # Process Incoming Parameters, defaulting as necessary - #------------------------------------------------------------ - $parms{preserveRaw} = 0 unless ( $parms{preserveRaw} ); - $parms{purge} = 2 unless $parms{purge}; - $parms{timebars} = 5 unless $parms{timebars}; - $parms{tableChannels} = 40 unless $parms{tableChannels}; - $parms{days} = 1 unless $parms{days}; - $parms{db} = 'tv' unless $parms{db}; - $parms{outdir} ="$config_parms{html_dir}/$parms{db}" +sub setup { + &main::read_mh_opts( \%config_parms, $Pgm_Path ); + + #------------------------------------------------------------ + # Process Incoming Parameters, defaulting as necessary + #------------------------------------------------------------ + $parms{preserveRaw} = 0 unless ( $parms{preserveRaw} ); + $parms{purge} = 2 unless $parms{purge}; + $parms{timebars} = 5 unless $parms{timebars}; + $parms{tableChannels} = 40 unless $parms{tableChannels}; + $parms{days} = 1 unless $parms{days}; + $parms{db} = 'tv' unless $parms{db}; + $parms{outdir} = "$config_parms{html_dir}/$parms{db}" unless $parms{outdir}; - $parms{zip} = $config_parms{zip_code} unless $parms{zip}; - $parms{proxy} = $ENV{http_proxy} unless $parms{proxy}; - $parms{proxy} = $ENV{HTTP_PROXY} unless $parms{proxy}; # Just in case (lc is the standard) - $parms{proxy} = $config_parms{proxy} unless $parms{proxy}; - $parms{provider}= $config_parms{$parms{db}.'_provider'} + $parms{zip} = $config_parms{zip_code} unless $parms{zip}; + $parms{proxy} = $ENV{http_proxy} unless $parms{proxy}; + $parms{proxy} = $ENV{HTTP_PROXY} + unless $parms{proxy}; # Just in case (lc is the standard) + $parms{proxy} = $config_parms{proxy} unless $parms{proxy}; + $parms{provider} = $config_parms{ $parms{db} . '_provider' } unless $parms{provider}; - $parms{provider_name} = $config_parms{$parms{db}.'_provider_name'} + $parms{provider_name} = $config_parms{ $parms{db} . '_provider_name' } unless $parms{provider_name}; - $parms{get_providers} = 0 unless ( $parms{get_providers} ); - $parms{hour} = $config_parms{$parms{db}.'_hours'} unless $parms{hour}; - $parms{skip} = $config_parms{$parms{db}.'_channels_skip'} - if ($config_parms{$parms{db}.'_channels_skip'} and !$parms{skip}); - $parms{keep} = $config_parms{$parms{db}.'_channels_keep'} - if ($config_parms{$parms{db}.'_channels_keep'} and !$parms{keep}); - $parms{name} = $config_parms{$parms{db}.'_name'} unless $parms{name}; + $parms{get_providers} = 0 unless ( $parms{get_providers} ); + $parms{hour} = $config_parms{ $parms{db} . '_hours' } unless $parms{hour}; + $parms{skip} = $config_parms{ $parms{db} . '_channels_skip' } + if ( $config_parms{ $parms{db} . '_channels_skip' } and !$parms{skip} ); + $parms{keep} = $config_parms{ $parms{db} . '_channels_keep' } + if ( $config_parms{ $parms{db} . '_channels_keep' } and !$parms{keep} ); + $parms{name} = $config_parms{ $parms{db} . '_name' } unless $parms{name}; $parms{hour} = '6pm' unless $parms{hour}; - if (lc($parms{hour}) eq 'all') { + if ( lc( $parms{hour} ) eq 'all' ) { @hours = qw(02 06 10 14 18 22); } - elsif (lc($parms{hour}) eq 'all_by_3') { + elsif ( lc( $parms{hour} ) eq 'all_by_3' ) { @hours = qw(02 05 08 11 14 17 20 23); } - elsif (1 < (@hours = split(',', $parms{hour}))) { + elsif ( 1 < ( @hours = split( ',', $parms{hour} ) ) ) { for (@hours) { - $_ = sprintf("%02d", $_); # force hour to be zero padded -# print "$_/n"; + $_ = sprintf( "%02d", $_ ); # force hour to be zero padded + + # print "$_/n"; } } - elsif (1 < (@hours = split(',', $parms{hour}))) { + elsif ( 1 < ( @hours = split( ',', $parms{hour} ) ) ) { } else { - my ($hour, $am_pm) = $parms{hour} =~ /(\d+) *(\S*)/; + my ( $hour, $am_pm ) = $parms{hour} =~ /(\d+) *(\S*)/; $hour += 12 unless lc($am_pm) eq 'am' or $hour == 12; - @hours = (sprintf("%02d", $hour)); + @hours = ( sprintf( "%02d", $hour ) ); + } + + $parms{duration} = $config_parms{ $parms{db} . '_duration' } + if ( $config_parms{ $parms{db} . '_duration' } ); + $parms{duration} = 4 unless ( $parms{duration} ); + + $parms{channel_min} = $config_parms{ $parms{db} . '_channel_min' } + if $config_parms{ $parms{db} . '_channel_min' }; + $parms{channel_max} = $config_parms{ $parms{db} . '_channel_max' } + if $config_parms{ $parms{db} . '_channel_max' }; + + $parms{zip} || die "Missing zipcode!"; + $parms{provider} + || $parms{provider_name} + || $parms{get_providers} + || die "Missing provider!"; + $parms{channel_min} = '1' unless $parms{channel_min}; + $parms{channel_max} = '99999' unless $parms{channel_max}; + $parms{label} = "VCR" unless $parms{label}; # This can also be an image link + $parms{days} = 1 unless $parms{days}; + $parms{redo} = 1 if $parms{reget}; + $parms{reget} = 1 if $parms{get_providers}; + $parms{duration} = 6 unless $parms{duration}; + + %channels_keep = map { $_, 1 } split( ',', $parms{keep} ) if $parms{keep}; + %channels_skip = map { $_, 1 } split( ',', $parms{skip} ) if $parms{skip}; + + # Allow for channel n-m format + for my $key ( keys %channels_keep ) { + if ( my @a = split '-', $key ) { + for my $i ( $a[0] .. $a[1] ) { + delete $channels_keep{$key}; + $channels_keep{$i}++; + } + } + } + for my $key ( keys %channels_skip ) { + if ( my @a = split '-', $key ) { + for my $i ( $a[0] .. $a[1] ) { + delete $channels_skip{$key}; + $channels_skip{$i}++; + } + } } + # Set up DBM files + $dbm_file = "$config_parms{data_dir}/$parms{db}_programs.dbm"; + $dbm_file2 = "$config_parms{data_dir}/$parms{db}_channels.dbm"; + print "Files will be stored to $parms{outdir}\n"; + print "Tieing to $dbm_file\n"; + use Fcntl; + use DB_File; + tie( %DBM, 'DB_File', $dbm_file, O_RDWR | O_CREAT, 0666 ) + or print "\nError, can not open dbm file $dbm_file: $!"; + tie( %DBM2, 'DB_File', $dbm_file2, O_RDWR | O_CREAT, 0666 ) + or print "\nError, can not open dbm file $dbm_file2: $!"; - $parms{duration}= $config_parms{$parms{db}.'_duration'} if ( $config_parms{$parms{db}.'_duration'} ); - $parms{duration}= 4 unless ( $parms{duration} ); - - $parms{channel_min} = $config_parms{$parms{db}.'_channel_min'} - if $config_parms{$parms{db} . '_channel_min'}; - $parms{channel_max} = $config_parms{$parms{db}.'_channel_max'} - if $config_parms{$parms{db} . '_channel_max'}; - - $parms{zip} || die "Missing zipcode!"; - $parms{provider} || $parms{provider_name} || $parms{get_providers} || die "Missing provider!"; - $parms{channel_min} = '1' unless $parms{channel_min}; - $parms{channel_max} = '99999' unless $parms{channel_max}; - $parms{label} = "VCR" unless $parms{label}; # This can also be an image link - $parms{days} = 1 unless $parms{days}; - $parms{redo} = 1 if $parms{reget}; - $parms{reget} = 1 if $parms{get_providers}; - $parms{duration} = 6 unless $parms{duration}; - - %channels_keep = map{$_, 1} split(',', $parms{keep}) if $parms{keep}; - %channels_skip = map{$_, 1} split(',', $parms{skip}) if $parms{skip}; - - # Allow for channel n-m format - for my $key (keys %channels_keep) { - if (my @a = split '-', $key) { - for my $i ($a[0] .. $a[1]) { - delete $channels_keep{$key}; - $channels_keep{$i}++; - } - } - } - for my $key (keys %channels_skip) { - if (my @a = split '-', $key) { - for my $i ($a[0] .. $a[1]) { - delete $channels_skip{$key}; - $channels_skip{$i}++; - } - } - } - - # Set up DBM files - $dbm_file = "$config_parms{data_dir}/$parms{db}_programs.dbm"; - $dbm_file2 = "$config_parms{data_dir}/$parms{db}_channels.dbm"; - print "Files will be stored to $parms{outdir}\n"; - print "Tieing to $dbm_file\n"; - use Fcntl; - use DB_File; - tie (%DBM, 'DB_File', $dbm_file, O_RDWR|O_CREAT, 0666) or print "\nError, can not open dbm file $dbm_file: $!"; - tie (%DBM2, 'DB_File', $dbm_file2, O_RDWR|O_CREAT, 0666) or print "\nError, can not open dbm file $dbm_file2: $!"; - - # Create any directories that need creating. - createOutputDirs(); - - # Initialize other global variables - $didLogIn = 0; - - $ua -> proxy(['http', 'ftp'] => $parms{proxy}) if $parms{proxy}; + # Create any directories that need creating. + createOutputDirs(); + + # Initialize other global variables + $didLogIn = 0; + + $ua->proxy( [ 'http', 'ftp' ] => $parms{proxy} ) if $parms{proxy}; } @@ -338,16 +360,16 @@ sub setup # SUB: setup_web_client # Set up WebClient and Cookie Jar #====================================================================== -sub setup_web_client -{ - $cookie_jar = HTTP::Cookies->new; -# $cookie_jar = HTTP::Cookies->new( ignore_discard => 1 ); +sub setup_web_client { + $cookie_jar = HTTP::Cookies->new; + + # $cookie_jar = HTTP::Cookies->new( ignore_discard => 1 ); - # Use the following if you want to examine the cookies. - #$cookie_jar = HTTP::Cookies->new( file => "lwpCookies.txt", - # autosave => 1, ignore_discard => 1 ); + # Use the following if you want to examine the cookies. + #$cookie_jar = HTTP::Cookies->new( file => "lwpCookies.txt", + # autosave => 1, ignore_discard => 1 ); - $ua -> cookie_jar( $cookie_jar ); + $ua->cookie_jar($cookie_jar); } @@ -355,27 +377,24 @@ sub setup_web_client # SUB: createOutputDirs # Create any directories/files that need creating prior to downloads #====================================================================== -sub createOutputDirs -{ - #------------------------------------------------------------ - # Create directories needed for downloading data - #------------------------------------------------------------ - mkdir $parms{outdir}, 0777 unless -d $parms{outdir}; - mkdir "$parms{outdir}/logos", 0777 unless -d "$parms{outdir}/logos"; - mkdir "$parms{outdir}/download", 0777 unless -d "$parms{outdir}/download"; - - if ( ! -d $parms{outdir} ) - { - print "FAILED TO MAKE DIR: $parms{outdir} \n"; - } - if ( ! -d $parms{outdir}."/logos" ) - { - print "FAILED TO MAKE DIR: $parms{outdir}/logos \n"; - } - if ( ! -d $parms{outdir}."/download" ) - { - print "FAILED TO MAKE DIR: $parms{outdir}/download \n"; - } +sub createOutputDirs { + + #------------------------------------------------------------ + # Create directories needed for downloading data + #------------------------------------------------------------ + mkdir $parms{outdir}, 0777 unless -d $parms{outdir}; + mkdir "$parms{outdir}/logos", 0777 unless -d "$parms{outdir}/logos"; + mkdir "$parms{outdir}/download", 0777 unless -d "$parms{outdir}/download"; + + if ( !-d $parms{outdir} ) { + print "FAILED TO MAKE DIR: $parms{outdir} \n"; + } + if ( !-d $parms{outdir} . "/logos" ) { + print "FAILED TO MAKE DIR: $parms{outdir}/logos \n"; + } + if ( !-d $parms{outdir} . "/download" ) { + print "FAILED TO MAKE DIR: $parms{outdir}/download \n"; + } } #====================================================================== @@ -383,183 +402,190 @@ sub createOutputDirs # Processes all requests through common code that can check status # responses, etc. #====================================================================== -sub submitRequest -{ - # Collect incoming arguments - my ($request, $outFile, $referer) = @_; - my $res; # Reponse - $request->content_type('application/x-www-form-urlencoded'); - $request->header('User-Agent' => 'Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 4.0)', - 'Referer' => ($referer ? $referer : 'http://tvlistings.zap2it.com/grid.asp'), - 'Accept' => '*/*', - 'Accept-Language' => 'en', - ); - - # Add any relevant cookies to the request - if ( ! ($request->as_string =~ /logo/ ) ) - { -# $cookie_jar->add_cookie_header( $request ); - } - - # Submit request - print "Request: [".($request->as_string).($cookie_jar->as_string)."]\n" if ($parms{debug}); - if ( $outFile ) - { - print "Submitting request with output file: $outFile \n" if ($parms{debug}); - if ( $dbgSubmitRequest ) - { - $res = $ua->request( $request, $outFile ); - } - } - else - { - print "Submitting request without output file\n" if ($parms{debug}); - if ( $dbgSubmitRequest ) - { - $res = $ua->request( $request ); - } - } - - -# Could use this instead of the is_redirect check below -# package myUserAgent; -# @ISA=qw(LWP::UserAgent); -# sub redirect_ok { return 1; } -# package main; - - - if ($res->is_redirect) - { - my $ur = $res->header('location') or die "missing location: ", $res->as_string; - print "is redirect to $ur\n" if ($parms{debug}); - $request = HTTP::Request->new( GET => $url.$ur ); - print "Request: [".($request->as_string).($cookie_jar->as_string)."]\n" if ($parms{debug}); - $res = $ua->request($request, $outFile); - return 1; - } - - # Minimizes problems during dry-runs (no net connection) - if ( ! $dbgSubmitRequest ) - { - print "DBG: Returning 1\n"; - return 1; - } - - # Process response data - if ( $res->status_line =~ /200/ ) - { - print "Response successful (200)\n" if ($parms{debug}); - return 1; - } - else - { - print "FAILED RESPONSE: ".$res->as_string."\n"; - return -1; - } +sub submitRequest { + + # Collect incoming arguments + my ( $request, $outFile, $referer ) = @_; + my $res; # Reponse + $request->content_type('application/x-www-form-urlencoded'); + $request->header( + 'User-Agent' => 'Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 4.0)', + 'Referer' => + ( $referer ? $referer : 'http://tvlistings.zap2it.com/grid.asp' ), + 'Accept' => '*/*', + 'Accept-Language' => 'en', + ); + + # Add any relevant cookies to the request + if ( !( $request->as_string =~ /logo/ ) ) { + + # $cookie_jar->add_cookie_header( $request ); + } + + # Submit request + print "Request: [" + . ( $request->as_string ) + . ( $cookie_jar->as_string ) . "]\n" + if ( $parms{debug} ); + if ($outFile) { + print "Submitting request with output file: $outFile \n" + if ( $parms{debug} ); + if ($dbgSubmitRequest) { + $res = $ua->request( $request, $outFile ); + } + } + else { + print "Submitting request without output file\n" if ( $parms{debug} ); + if ($dbgSubmitRequest) { + $res = $ua->request($request); + } + } + + # Could use this instead of the is_redirect check below + # package myUserAgent; + # @ISA=qw(LWP::UserAgent); + # sub redirect_ok { return 1; } + # package main; + + if ( $res->is_redirect ) { + my $ur = $res->header('location') + or die "missing location: ", $res->as_string; + print "is redirect to $ur\n" if ( $parms{debug} ); + $request = HTTP::Request->new( GET => $url . $ur ); + print "Request: [" + . ( $request->as_string ) + . ( $cookie_jar->as_string ) . "]\n" + if ( $parms{debug} ); + $res = $ua->request( $request, $outFile ); + return 1; + } + + # Minimizes problems during dry-runs (no net connection) + if ( !$dbgSubmitRequest ) { + print "DBG: Returning 1\n"; + return 1; + } + + # Process response data + if ( $res->status_line =~ /200/ ) { + print "Response successful (200)\n" if ( $parms{debug} ); + return 1; + } + else { + print "FAILED RESPONSE: " . $res->as_string . "\n"; + return -1; + } } #====================================================================== # login #====================================================================== -sub login -{ - my ( $this_provider ) = @_; # use $parms{provider} if empty - - #------------------------------------------------------------ - # Prepare our web-browsing tools for use - #------------------------------------------------------------ - setup_web_client(); - - #------------------------------------------------------------ - # First submission, to obtain the ASPSESSIONID cookie - #------------------------------------------------------------ - print "1 of 4\n" if $parms{debug}; - my $submitResult = 0; - $submitResult = submitRequest( HTTP::Request->new( GET => $url . 'index.asp?partner_id=national'), "$config_parms{data_dir}/out1.txt", 'http://tvlistings5.zap2it.com/tvlistings/GridAction.do' ); - if ( 1 != $submitResult ) - { - return -1; - } - - #------------------------------------------------------------ - # Second submission, to submit our zip code - #------------------------------------------------------------ - - my $req_zip= HTTP::Request->new( POST => $url . "zipcode.asp?partner_id=national&zipcode=$parms{zip}" ); - $req_zip->content( "zipcode=$parms{zip}&" - ."partner_id=national&" - ."FormName=zipcode.asp&" - ."submit1=Continue" ); - $req_zip->content_type('application/x-www-form-urlencoded'); - print "2 of 4\n" if $parms{debug}; - $submitResult = submitRequest( $req_zip, "$config_parms{data_dir}/tv_providers.html" ); - if ( 1 != $submitResult ) - { - return -1; - } - - #------------------------------------------------------------ - # Third submission, to submit our provider & get listings - # (A real waste, since it gives us data we might not use, but - # really should. However, it does get us to the point where we can - # collect the data we actually want. Skipping this step seems - # to result in an error though, so I guess we're stuck.) - #------------------------------------------------------------ - - if (!$parms{provider} or $parms{get_providers}) { - &get_providers; - exit if $parms{get_providers}; - my @provs; - foreach ( split( /,\s*/, $parms{provider_name} ) ) { - if ($providers{$_}) { - push( @provs, $providers{$_} ); - print "Using TV provider ID $providers{$_} for '$_'\n"; - } - else { - print "Couldn't find TV provider '$_'\n"; - return -1; - } - } - $parms{provider} = join(',',@provs); - } - - if ( !defined $this_provider ) { - ($this_provider) = split( /,\s*/, $parms{provider} ); # first time through, take the first one - } - my $req_prov = HTTP::Request->new(POST => $url . "system.asp?partner_id=national&zipcode=$parms{zip}"); - $req_prov->content( "provider=$this_provider&" - ."saveProvider=See%20Listings&" - ."zipCode=$parms{zip}&" - ."FormName=system.asp&" - ."page_from=" ); - $req_prov->content_type('application/x-www-form-urlencoded'); - #submitRequest( $req_prov, "out3.txt" ); - print "3 of 4\n" if $parms{debug}; - $submitResult = submitRequest( $req_prov ); - if ( 1 != $submitResult ) - { - return -1; - } - - #------------------------------------------------------------ - # Fourth submission. If you thought the last one was a waste, you - # ain't seen nothin! The javascript form doesn't trigger 'all channels', - # so we have to do that with this step before asking for specific - # dates/times - #------------------------------------------------------------ - my $req_allChans = HTTP::Request->new(GET => $url.'listings_redirect.asp?spp=0'); - print "4 of 4\n" if $parms{debug}; - $submitResult = submitRequest( $req_allChans ); - if ( 1 != $submitResult ) - { - return -1; - } - - #------------------------------------------------------------ - # If we got this far, return successful result! - #------------------------------------------------------------ - print "Login complete!\n"; - return 1; +sub login { + my ($this_provider) = @_; # use $parms{provider} if empty + + #------------------------------------------------------------ + # Prepare our web-browsing tools for use + #------------------------------------------------------------ + setup_web_client(); + + #------------------------------------------------------------ + # First submission, to obtain the ASPSESSIONID cookie + #------------------------------------------------------------ + print "1 of 4\n" if $parms{debug}; + my $submitResult = 0; + $submitResult = submitRequest( + HTTP::Request->new( GET => $url . 'index.asp?partner_id=national' ), + "$config_parms{data_dir}/out1.txt", + 'http://tvlistings5.zap2it.com/tvlistings/GridAction.do' + ); + if ( 1 != $submitResult ) { + return -1; + } + + #------------------------------------------------------------ + # Second submission, to submit our zip code + #------------------------------------------------------------ + + my $req_zip = + HTTP::Request->new( + POST => $url . "zipcode.asp?partner_id=national&zipcode=$parms{zip}" ); + $req_zip->content( "zipcode=$parms{zip}&" + . "partner_id=national&" + . "FormName=zipcode.asp&" + . "submit1=Continue" ); + $req_zip->content_type('application/x-www-form-urlencoded'); + print "2 of 4\n" if $parms{debug}; + $submitResult = + submitRequest( $req_zip, "$config_parms{data_dir}/tv_providers.html" ); + if ( 1 != $submitResult ) { + return -1; + } + + #------------------------------------------------------------ + # Third submission, to submit our provider & get listings + # (A real waste, since it gives us data we might not use, but + # really should. However, it does get us to the point where we can + # collect the data we actually want. Skipping this step seems + # to result in an error though, so I guess we're stuck.) + #------------------------------------------------------------ + + if ( !$parms{provider} or $parms{get_providers} ) { + &get_providers; + exit if $parms{get_providers}; + my @provs; + foreach ( split( /,\s*/, $parms{provider_name} ) ) { + if ( $providers{$_} ) { + push( @provs, $providers{$_} ); + print "Using TV provider ID $providers{$_} for '$_'\n"; + } + else { + print "Couldn't find TV provider '$_'\n"; + return -1; + } + } + $parms{provider} = join( ',', @provs ); + } + + if ( !defined $this_provider ) { + ($this_provider) = split( /,\s*/, $parms{provider} ) + ; # first time through, take the first one + } + my $req_prov = + HTTP::Request->new( + POST => $url . "system.asp?partner_id=national&zipcode=$parms{zip}" ); + $req_prov->content( "provider=$this_provider&" + . "saveProvider=See%20Listings&" + . "zipCode=$parms{zip}&" + . "FormName=system.asp&" + . "page_from=" ); + $req_prov->content_type('application/x-www-form-urlencoded'); + + #submitRequest( $req_prov, "out3.txt" ); + print "3 of 4\n" if $parms{debug}; + $submitResult = submitRequest($req_prov); + if ( 1 != $submitResult ) { + return -1; + } + + #------------------------------------------------------------ + # Fourth submission. If you thought the last one was a waste, you + # ain't seen nothin! The javascript form doesn't trigger 'all channels', + # so we have to do that with this step before asking for specific + # dates/times + #------------------------------------------------------------ + my $req_allChans = + HTTP::Request->new( GET => $url . 'listings_redirect.asp?spp=0' ); + print "4 of 4\n" if $parms{debug}; + $submitResult = submitRequest($req_allChans); + if ( 1 != $submitResult ) { + return -1; + } + + #------------------------------------------------------------ + # If we got this far, return successful result! + #------------------------------------------------------------ + print "Login complete!\n"; + return 1; } #====================================================================== @@ -568,158 +594,163 @@ sub login # To maintain backward compatibility, only add provider index if > 0 #====================================================================== sub providerFilename { - my ( $ofile, $provnum ) = @_; - - if ( $provnum ) { - if ( $ofile =~ /\./ ) { - $ofile =~ s/(\.[^.]*)$/_$provnum$1/; - } - else { - $ofile .= "_$provnum"; - } - } - return $ofile; + my ( $ofile, $provnum ) = @_; + + if ($provnum) { + if ( $ofile =~ /\./ ) { + $ofile =~ s/(\.[^.]*)$/_$provnum$1/; + } + else { + $ofile .= "_$provnum"; + } + } + return $ofile; } #====================================================================== # fetchDataToFile # #====================================================================== -sub fetchDataToFile -{ - my ( $outfile, $startDay, $startHour ) = @_; - - #------------------------------------------------------------ - # If output file already exists, and is recent enough, use - # keep it instead of re-downloading. - #------------------------------------------------------------ -# my $M = -M $outfile; my $s = -s $outfile; print "db of=$outfile m=$M s=$s\n"; - - if ( (-e $outfile) and (8 > -M $outfile) and - (4000 < -s $outfile) and !$parms{reget} ) - { - print "Reusing: $outfile\n"; - } - - - #------------------------------------------------------------ - # Retrieve the HTML listings for this date/time & duration - #------------------------------------------------------------ - else - { - #------------------------------------------------------------ - # If we're not logged in, do so now. - #------------------------------------------------------------ - if ( ! $didLogIn ) - { - my( @providers, $this_provider ); - do - { - print "Logging in...\n" if $parms{debug}; - $didLogIn = login( $this_provider ); - if ( 1 != $didLogIn ) - { - print "Login failed!: $didLogIn\n"; - return -1; +sub fetchDataToFile { + my ( $outfile, $startDay, $startHour ) = @_; + + #------------------------------------------------------------ + # If output file already exists, and is recent enough, use + # keep it instead of re-downloading. + #------------------------------------------------------------ + # my $M = -M $outfile; my $s = -s $outfile; print "db of=$outfile m=$M s=$s\n"; + + if ( ( -e $outfile ) + and ( 8 > -M $outfile ) + and ( 4000 < -s $outfile ) + and !$parms{reget} ) + { + print "Reusing: $outfile\n"; + } + + #------------------------------------------------------------ + # Retrieve the HTML listings for this date/time & duration + #------------------------------------------------------------ + else { + #------------------------------------------------------------ + # If we're not logged in, do so now. + #------------------------------------------------------------ + if ( !$didLogIn ) { + my ( @providers, $this_provider ); + do { + print "Logging in...\n" if $parms{debug}; + $didLogIn = login($this_provider); + if ( 1 != $didLogIn ) { + print "Login failed!: $didLogIn\n"; + return -1; + } + if ( !@uas ) { + @providers = split( /,\s*/, $parms{provider} ); + $this_provider = + shift @providers; # what we just logged-into + } + push( + @uas, + { + 'ua' => $ua, + 'cookie_jar' => $cookie_jar, + 'provider' => $this_provider + } + ); + if ( $this_provider = shift @providers ) + { # prepare for next request + $ua = new RedirAgent(); + $cookie_jar = HTTP::Cookies->new; + $ua->cookie_jar($cookie_jar); + } + } while ($this_provider); + } + + #------------------------------------------------------------ + # Retrieve the file we need + #------------------------------------------------------------ + print + "Requesting data for ${startDay} at $startHour for $parms{duration} hours\n"; + + # $startHour -= 2; + my $provnum; + foreach (@uas) { + $ua = $_->{ua}; + $cookie_jar = $_->{cookie_jar}; + my $ofile = providerFilename( $outfile, $provnum ); + my $loopReq = + HTTP::Request->new( POST => $url . 'listings_redirect.asp' ); + $loopReq->content( "displayType=Grid&" + . "duration=$parms{duration}&" + . "startDay=${startDay}&" + . "startTime=${startHour}&" + . "category=0&" + . "station=0&" + . "goButton=GO" ); + + $loopReq->content_type('application/x-www-form-urlencoded'); + my $submitResult = submitRequest( $loopReq, $ofile ); + my $loopReq = + HTTP::Request->new( GET => $url . 'listings_redirect.asp?spp=0' ); + my $submitResult = submitRequest( $loopReq, $ofile ); + if ( 1 != $submitResult ) { + return -1; } - if ( !@uas ) { - @providers = split( /,\s*/, $parms{provider} ); - $this_provider = shift @providers; # what we just logged-into + + #------------------------------------------------------------ + # Verify that we actually got a usable output file + #------------------------------------------------------------ + if ( ( -e $ofile ) and ( 4000 < -s $ofile ) ) { + print "Verified: $ofile\n"; } - push( @uas, { 'ua' => $ua, - 'cookie_jar' => $cookie_jar, - 'provider' => $this_provider } ); - if ( $this_provider = shift @providers ) { # prepare for next request - $ua = new RedirAgent(); - $cookie_jar = HTTP::Cookies->new; - $ua -> cookie_jar( $cookie_jar ); + else { + print "Error!: Missing or Truncated: $ofile \n"; + return -1; } - } while ( $this_provider ); - } - - #------------------------------------------------------------ - # Retrieve the file we need - #------------------------------------------------------------ - print "Requesting data for ${startDay} at $startHour for $parms{duration} hours\n"; -# $startHour -= 2; - my $provnum; - foreach ( @uas ) { - $ua = $_->{ua}; - $cookie_jar = $_->{cookie_jar}; - my $ofile = providerFilename( $outfile, $provnum ); - my $loopReq = HTTP::Request->new( - POST => $url.'listings_redirect.asp'); - $loopReq->content( - "displayType=Grid&" - ."duration=$parms{duration}&" - ."startDay=${startDay}&" - ."startTime=${startHour}&" - ."category=0&" - ."station=0&" - ."goButton=GO" ); - - $loopReq->content_type('application/x-www-form-urlencoded'); - my $submitResult = submitRequest( $loopReq, $ofile ); - my $loopReq = HTTP::Request->new( - GET => $url.'listings_redirect.asp?spp=0'); - my $submitResult = submitRequest( $loopReq, $ofile ); - if ( 1 != $submitResult ) - { - return -1; - } - - #------------------------------------------------------------ - # Verify that we actually got a usable output file - #------------------------------------------------------------ - if ( (-e $ofile) and (4000 < -s $ofile) ) - { - print "Verified: $ofile\n"; - } - else - { - print "Error!: Missing or Truncated: $ofile \n"; - return -1; - } - $provnum++; - } - } - return 1; + $provnum++; + } + } + return 1; } #====================================================================== # SUB: prov_count #====================================================================== sub prov_count { - my $prov_count = @uas; - # @uas is not set when redoing, so count providers from commandline - if ( !$prov_count && $parms{redo} ) { - my @p1 = split(/,\s*/,$parms{provider}); - if ( !($prov_count = @p1) ) { - my @p2 = split(/,\s*/,$parms{provider_name}); - $prov_count = @p2; - } - } - return $prov_count; + my $prov_count = @uas; + + # @uas is not set when redoing, so count providers from commandline + if ( !$prov_count && $parms{redo} ) { + my @p1 = split( /,\s*/, $parms{provider} ); + if ( !( $prov_count = @p1 ) ) { + my @p2 = split( /,\s*/, $parms{provider_name} ); + $prov_count = @p2; + } + } + return $prov_count; } #====================================================================== # SUB: processRawFile #====================================================================== -sub processRawFile -{ - my ( $day_time, $hour, $down, $rawFile, $outfile, $dow, $month, $day, $year, $tomorrow_month, $tomorrow_day ) = @_; - print "Processing $rawFile to $outfile\n" if ($parms{debug}); - - #------------------------------------------------------------ - # Open files and start the output HTML - #------------------------------------------------------------ - my $min = $hour*60; - foreach my $provnum ( 0..&prov_count()-1 ) { - my $rawFileProv = providerFilename( $rawFile, $provnum ); - open (IN, "$rawFileProv") || die "Error, could not open file $rawFileProv: $!\n"; - if ( !$provnum ) { # print header first time through - open (OUT, ">$outfile") || die "Error, could not open file $outfile: $!\n"; - print OUT<$outfile" ) + || die "Error, could not open file $outfile: $!\n"; + print OUT< $parms{name} Schedule for $dow, $month/$day/$year @@ -729,466 +760,489 @@ sub processRawFile eof - } - print "Filtering $rawFileProv to $outfile\n" if $parms{debug}; - - #------------------------------------------------------------ - # Create & initialize local variables for processing - #------------------------------------------------------------ - my ($record, $record_prev, $script, $loop_phase, $count1, $count2, $count3 ); - my ($pgm_desc, $min_start, $min_end, $min_pgm) = 0; - - $count1 = $count2 = $count3 = 0; - my $channel_number = ''; - my $channel_name = ''; - my $pgm_name = ''; - my $channelRowsSaved = 0; - my $current_time_bar = ''; - my $rowOfLastTimeBar = 0; - my $tableStartText = qq||; - my $rowsInCurrentOutTable = 0; - my $script_flag = 0; - - #---------------------------------------------------------------------- - # Cycle through each raw HTML line to produce the filtered version - # Phases: - # - Global = Applies to all passes through the loop - # - 0 = Raw HTML prior to Grid data - # - 1 = Raw HTML of Grid data - # - 2 = Raw HTML after Grid data ("footer") - # - 3 = Done processing file - #---------------------------------------------------------------------- - $loop_phase = 0; - while ( $record = ) - { - if ( $loop_phase >= 4 ) - { - last; - } - # Increment count of raw HTML processed - # FIXME: Use array of $count{Raw} instead of multiple counts - $count1++; - - #====================================================================== - # PHASE: GLOBAL - #====================================================================== - - #---------------------------------------------------------------------- - # Eliminate all javascript from input file. - #---------------------------------------------------------------------- - # Eliminate one-liners - if ( $record =~ /\n] unless $script =~ / script /i; - $html = $script . "\n"; + + # print "dbx1 s=$script\n\n"; + $script = qq[\n] + unless $script =~ / script /i; + $html = $script . "\n"; } -$html .= " + $html .= " $style $title @@ -1743,8 +2026,9 @@ sub html_page { $extraheaders .= $frame . "\n\r" if $frame; $extraheaders .= "\n\r" if $extraheaders; - # Not sure how important length is, but pretty cheap and easy to do - $html =~ s/\n/\n\r/g; # Bill S. says this is required to be standards compiliant + # Not sure how important length is, but pretty cheap and easy to do + $html =~ + s/\n/\n\r/g; # Bill S. says this is required to be standards compiliant return <\n] . - qq[\n] if $html_info_overlib; + $h_index = + qq[
\n] + . qq[\n] + if $html_info_overlib; - for my $category (&list_code_webnames('Voice_Cmd')) { + for my $category ( &list_code_webnames('Voice_Cmd') ) { next if $category =~ /^none$/; my $info = "$category:"; - my $accesskey = substr($category,0,1); + my $accesskey = substr( $category, 0, 1 ); if ($html_info_overlib) { - if (my @files = &list_files_by_webname($category)) { - $info .= '
  • ' . join ('
  • ', @files); + if ( my @files = &list_files_by_webname($category) ) { + $info .= '
  • ' . join( '
  • ', @files ); } -# $info = qq[onMouseOver="overlib('$info', FIXX, 5, OFFSETY, 50 )" onMouseOut="nd();"]; - $info = qq[onMouseOver="overlib('$info', RIGHT, OFFSETY, 50 )" onMouseOut="nd();"]; + + # $info = qq[onMouseOver="overlib('$info', FIXX, 5, OFFSETY, 50 )" onMouseOut="nd();"]; + $info = + qq[onMouseOver="overlib('$info', RIGHT, OFFSETY, 50 )" onMouseOut="nd();"]; + } + + # Create buttons with GD module if available + if ( $Info{module_GD} ) { + $h_index .= + qq[$category\n]; } - # Create buttons with GD module if available - if ($Info{module_GD}) { - $h_index .= qq[$category\n]; } else { - $h_index .= "
  • " . qq[$category\n]; + $h_index .= "
  • " + . qq[$category\n]; } } return $h_index; @@ -1806,21 +2098,25 @@ sub html_category { sub html_groups { my $h_index; - for my $group (&list_objects_by_type('Group')) { + for my $group ( &list_objects_by_type('Group') ) { - # No need to list empty groups + # No need to list empty groups my $object = &get_object_by_name($1); - if ($object and $object->can('list')) { + if ( $object and $object->can('list') ) { next unless grep !$$_{hidden}, list $object; } - # Create buttons with GD module if available - if ($Info{module_GD}) { + # Create buttons with GD module if available + if ( $Info{module_GD} ) { my $name = &pretty_object_name($group); - $h_index .= qq[$name\n]; + $h_index .= + qq[$name\n]; } else { - $h_index .= "
  • " . &html_active_href("list?group=$group", &pretty_object_name($group)) . "\n"; + $h_index .= "
  • " + . &html_active_href( "list?group=$group", + &pretty_object_name($group) ) + . "\n"; } } return $h_index; @@ -1828,106 +2124,134 @@ sub html_groups { sub html_items { my $h_index; -# for my $object_type ('X10_Item', 'X10_Appliance', 'Group', 'iButton', 'Serial_Item') { + + # for my $object_type ('X10_Item', 'X10_Appliance', 'Group', 'iButton', 'Serial_Item') { for my $object_type (@Object_Types) { - next if $object_type eq 'Voice_Cmd'; # Already covered under Category - # Create buttons with GD module if available - if ($Info{module_GD}) { - $h_index .= qq[$object_type\n]; + next if $object_type eq 'Voice_Cmd'; # Already covered under Category + # Create buttons with GD module if available + if ( $Info{module_GD} ) { + $h_index .= + qq[$object_type\n]; } else { - $h_index .= "
  • " . &html_active_href("list?$object_type", $object_type) . "\n"; + $h_index .= "
  • " + . &html_active_href( "list?$object_type", $object_type ) . "\n"; } } return $h_index; } sub html_find_icon_image { - my ($object, $type) = @_; - my ($name, $state, $icon, $ext, $member); + my ( $object, $type ) = @_; + my ( $name, $state, $icon, $ext, $member ); $type = lc $type; - if ($type eq 'text') { + if ( $type eq 'text' ) { $name = $object; } else { - $name = lc $object->{object_name}; -# $state = lc $object->{state}; + $name = lc $object->{object_name}; + + # $state = lc $object->{state}; $state = lc $object->state(); - $state = lc $object->state_level() if ($type eq 'x10_item' or - $type eq 'x10_switchlinc') ; - $state = 'on' if $state eq '100%'; - $state = 'dim' if $state =~ /^\d\d?%$/; - $name =~ s/^\$//; # remove $ at front of objects - $name =~ s/^v_//; # remove v_ in voice commands - # Use on/off icons for conditional Weather_Items - $state = ($state) ? 'on' : 'off' if $type eq 'weather_item' and ($object->{comparison}); - # Remove min/max from normal and alert states on RF_Items + $state = lc $object->state_level() + if ( $type eq 'x10_item' + or $type eq 'x10_switchlinc' ); + $state = 'on' if $state eq '100%'; + $state = 'dim' if $state =~ /^\d\d?%$/; + $name =~ s/^\$//; # remove $ at front of objects + $name =~ s/^v_//; # remove v_ in voice commands + # Use on/off icons for conditional Weather_Items + $state = ($state) ? 'on' : 'off' + if $type eq 'weather_item' and ( $object->{comparison} ); + + # Remove min/max from normal and alert states on RF_Items $state =~ s/(normal|alert)(min|max)$/$1/i; - # Allow for set_icon to set the icon directly + + # Allow for set_icon to set the icon directly $name = $object->{icon} if $object->{icon}; - if ($type eq 'eibrb_item') { - $state = sprintf("%.0f",$state / 10 ) * 10; + if ( $type eq 'eibrb_item' ) { + $state = sprintf( "%.0f", $state / 10 ) * 10; } return '' if $name eq 'none'; } - print "Find_icon: object_name=$name, type=$type, state=$state\n" if $main::Debug{http}; + print "Find_icon: object_name=$name, type=$type, state=$state\n" + if $main::Debug{http}; unless (%html_icons) { undef %html_icons; - # If we have multiple dirs, the first one wins (last one in mh.ini file) - for my $dir (@{$http_dirs{'/graphics'}}) { + + # If we have multiple dirs, the first one wins (last one in mh.ini file) + for my $dir ( @{ $http_dirs{'/graphics'} } ) { print "Reading html icons from $dir\n" if $main::Debug{http}; - opendir (ICONS, $dir); + opendir( ICONS, $dir ); - for $member (readdir ICONS) { - ($icon, $ext) = $member =~ /(\S+)\.(\S+)/; + for $member ( readdir ICONS ) { + ( $icon, $ext ) = $member =~ /(\S+)\.(\S+)/; $ext = lc $ext; - next unless $ext and ($ext eq 'gif' or $ext eq 'jpg' or $ext eq 'png'); + next + unless $ext + and ( $ext eq 'gif' or $ext eq 'jpg' or $ext eq 'png' ); $icon = lc $icon; - # Give .jpg files a preference as these are supported by GD from web/bin/button.pl - $html_icons{$icon} = $member unless $html_icons{$icon} and $html_icons{$icon} =~ /.jpg$/i; + + # Give .jpg files a preference as these are supported by GD from web/bin/button.pl + $html_icons{$icon} = $member + unless $html_icons{$icon} and $html_icons{$icon} =~ /.jpg$/i; } } } - # Look for exact matches - if ($icon = $html_icons{"$name-$state"} or - $icon = $html_icons{$name}) { + # Look for exact matches + if ( $icon = $html_icons{"$name-$state"} + or $icon = $html_icons{$name} ) + { } - # For voice items, look for approximate name matches - # - Order of preference: object, text, filename - # and pick the longest named match - elsif ($type eq 'voice' or $type eq 'text') { - my ($i1, $i2, $i3, $l1, $l2, $l3); + + # For voice items, look for approximate name matches + # - Order of preference: object, text, filename + # and pick the longest named match + elsif ( $type eq 'voice' or $type eq 'text' ) { + my ( $i1, $i2, $i3, $l1, $l2, $l3 ); $l1 = $l2 = $l3 = 0; - for my $member (sort keys %html_icons) { + for my $member ( sort keys %html_icons ) { next if $member eq 'on' or $member eq 'off'; my $l = length $member; - if ($html_icons{$member}) { - if($name =~ /$member/i and $l > $l1) { $i1 = $html_icons{$member}; $l1 = $l}; - unless ($type eq 'text') { - if($object->{text} =~ /$member/i and $l > $l2) { $i2 = $html_icons{$member}; $l2 = $l}; - if($object->{filename} =~ /$member/i and $l > $l3) { $i3 = $html_icons{$member}; $l3 = $l}; + if ( $html_icons{$member} ) { + if ( $name =~ /$member/i and $l > $l1 ) { + $i1 = $html_icons{$member}; + $l1 = $l; + } + unless ( $type eq 'text' ) { + if ( $object->{text} =~ /$member/i and $l > $l2 ) { + $i2 = $html_icons{$member}; + $l2 = $l; + } + if ( $object->{filename} =~ /$member/i and $l > $l3 ) { + $i3 = $html_icons{$member}; + $l3 = $l; + } } } -# print "db n=$name t=$object->{text} $i1,$i2,$i3 l=$l m=$member\n" if $object->{text} =~ /playlist/; + + # print "db n=$name t=$object->{text} $i1,$i2,$i3 l=$l m=$member\n" if $object->{text} =~ /playlist/; } - if ($i1) {$icon = $i1} - elsif ($i2) {$icon = $i2} - elsif ($i3) {$icon = $i3} + if ($i1) { $icon = $i1 } + elsif ($i2) { $icon = $i2 } + elsif ($i3) { $icon = $i3 } else { - return ''; # No match + return ''; # No match } } - # For non-voice items, try State and Item type matches + + # For non-voice items, try State and Item type matches else { - unless ($icon = $html_icons{"$type-$state"} or - $icon = $html_icons{$type} or - $icon = $html_icons{$state}) { - return ''; # No match + unless ( $icon = $html_icons{"$type-$state"} + or $icon = $html_icons{$type} + or $icon = $html_icons{$state} ) + { + return ''; # No match } } @@ -1938,15 +2262,18 @@ sub html_find_icon_image { # but the function form allows for a more complicated referer string. sub button_action { my ($args) = @_; - my ($object_name, $state, $referer, $xy) = split ',', $args; + my ( $object_name, $state, $referer, $xy ) = split ',', $args; - my ($x, $y) = $xy =~ /(\d+)\|(\d+)/; + my ( $x, $y ) = $xy =~ /(\d+)\|(\d+)/; - # Do not dim the dishwasher :) - unless (eval qq|UNIVERSAL::isa($object_name, 'X10_Appliance')| - or eval qq|ref($object_name) && $object_name->can('is_dimmable') && !($object_name->is_dimmable)|) { - $state = 'dim' if $x < 30; # Left side of image - $state = 'brighten' if $x > 70; # Right side of image + # Do not dim the dishwasher :) + unless ( eval qq|UNIVERSAL::isa($object_name, 'X10_Appliance')| + or eval + qq|ref($object_name) && $object_name->can('is_dimmable') && !($object_name->is_dimmable)| + ) + { + $state = 'dim' if $x < 30; # Left side of image + $state = 'brighten' if $x > 70; # Right side of image } eval qq|$object_name->set("$state")|; @@ -1958,14 +2285,14 @@ sub button_action { } sub html_header { - my ($text, $title) = @_; - $text = 'Generic Header' unless $text; - $title = 'Misterhouse' unless $title; + my ( $text, $title ) = @_; + $text = 'Generic Header' unless $text; + $title = 'Misterhouse' unless $title; my $color = $config_parms{html_color_header}; $color = '#9999cc' unless $color; -return qq[ + return qq[ $title @@ -1982,15 +2309,15 @@ sub html_header { } sub html_header_new { -if ($Authorized) { + if ($Authorized) { - my ($text) = @_; - $text = 'Generic Header' unless $text; + my ($text) = @_; + $text = 'Generic Header' unless $text; - my $color = $config_parms{html_color_header}; - $color = '#9999cc' unless $color; + my $color = $config_parms{html_color_header}; + $color = '#9999cc' unless $color; -return qq[ + return qq[ $config_parms{html_style}
    • @@ -2000,15 +2327,15 @@ sub html_header_new {

    ]; -} -else { -my ($text) = @_; - $text = 'Sorry Unauthorized to View This Function'; + } + else { + my ($text) = @_; + $text = 'Sorry Unauthorized to View This Function'; - my $color = $config_parms{html_color_header}; - $color = '#9999cc' unless $color; + my $color = $config_parms{html_color_header}; + $color = '#9999cc' unless $color; -return qq[ + return qq[ $config_parms{html_style}
    @@ -2018,486 +2345,605 @@ sub html_header_new {

    ]; -} + } } sub html_list { - my($webname_or_object_type, $auto_refresh) = @_; - my ($object, @object_list, $num, $h_list); + my ( $webname_or_object_type, $auto_refresh ) = @_; + my ( $object, @object_list, $num, $h_list ); - $h_list .= &html_header ("Browse $webname_or_object_type    " . &html_authorized); - $h_list =~ s/group=\$//; # Drop the group=$ prefix on group lists + $h_list .= &html_header( + "Browse $webname_or_object_type    " + . &html_authorized ); + $h_list =~ s/group=\$//; # Drop the group=$ prefix on group lists $h_list .= qq[\n]; - # This means the form was submited ... check for search keyword - # Now better done with /bin/command_search.pl?string - if (my ($search) = $webname_or_object_type =~ /search=(.*)/) { + # This means the form was submited ... check for search keyword + # Now better done with /bin/command_search.pl?string + if ( my ($search) = $webname_or_object_type =~ /search=(.*)/ ) { - # Search for matching Voice_Cmd and Tk Widgets + # Search for matching Voice_Cmd and Tk Widgets $h_list .= "\n"; my %seen; - for my $cmd (&list_voice_cmds_match($search)) { - # Now find object name - my ($file, $cmd2) = $cmd =~ /(.+)\:(.+)/; - my ($object, $said, $vocab_cmd) = &Voice_Cmd::voice_item_by_text(lc $cmd2); + for my $cmd ( &list_voice_cmds_match($search) ) { + + # Now find object name + my ( $file, $cmd2 ) = $cmd =~ /(.+)\:(.+)/; + my ( $object, $said, $vocab_cmd ) = + &Voice_Cmd::voice_item_by_text( lc $cmd2 ); my $object_name = $object->{object_name}; next if $seen{$object_name}++; push @object_list, $object_name; } - $h_list .= &widgets('search', $search); + $h_list .= &widgets( 'search', $search ); $h_list .= &html_command_table(@object_list); return $h_list; } - - # Check for authority based searches - if ($webname_or_object_type =~ /authority=(\S*)/) { + # Check for authority based searches + if ( $webname_or_object_type =~ /authority=(\S*)/ ) { my $search = $1; - for my $category (&list_code_webnames('Voice_Cmd')) { - for my $object_name (sort &list_objects_by_webname($category)) { + for my $category ( &list_code_webnames('Voice_Cmd') ) { + for my $object_name ( sort &list_objects_by_webname($category) ) { my $object = &get_object_by_name($object_name); - next unless $object and UNIVERSAL::isa($object, 'Voice_Cmd'); - # for now, only list set_authority('anyone') commands + next unless $object and UNIVERSAL::isa( $object, 'Voice_Cmd' ); + + # for now, only list set_authority('anyone') commands my $authority = $object->get_authority; - push @object_list, $object_name if $authority and $authority =! /$search/i; + push @object_list, $object_name + if $authority and $authority = !/$search/i; } } $h_list .= "\n"; -# $h_list .= &widgets('search', $1); + + # $h_list .= &widgets('search', $1); $h_list .= &html_command_table(@object_list); return $h_list; } - # List Groups (treat them the same as Items) - if ($webname_or_object_type =~ /^group=(\S+)/) { + # List Groups (treat them the same as Items) + if ( $webname_or_object_type =~ /^group=(\S+)/ ) { $h_list .= "\n"; my $object = &get_object_by_name($1); - # Ignore objects marked as hidden - my @objects = grep !$$_{hidden}, list $object if $object and $object->can('list'); - my @table_items = map{&html_item_state($_, $webname_or_object_type)} @objects; - $h_list .= &table_it($config_parms{'html_table_size' . $Http{format}}, 0, 0, @table_items); + # Ignore objects marked as hidden + my @objects = grep !$$_{hidden}, list $object + if $object and $object->can('list'); + + my @table_items = + map { &html_item_state( $_, $webname_or_object_type ) } @objects; + $h_list .= + &table_it( $config_parms{ 'html_table_size' . $Http{format} }, + 0, 0, @table_items ); return $h_list; } - # List Items by type - if (@object_list = sort &list_objects_by_type($webname_or_object_type)) { - $h_list .= qq[\n] - if $auto_refresh and $main::config_parms{'html_refresh_rate' . $Http{format}}; - $h_list .= "\n"; - my @objects = map{&get_object_by_name($_)} @object_list; + # List Items by type + if ( @object_list = sort &list_objects_by_type($webname_or_object_type) ) { + $h_list .= + qq[\n] + if $auto_refresh + and $main::config_parms{ 'html_refresh_rate' . $Http{format} }; + $h_list .= + "\n"; + my @objects = map { &get_object_by_name($_) } @object_list; - # Ignore objects marked as hidden + # Ignore objects marked as hidden @objects = grep !$$_{hidden}, @objects; - my @table_items = map{&html_item_state($_, $webname_or_object_type)} @objects; - $h_list .= &table_it($main::config_parms{'html_table_size' . $Http{format}}, 0, 0, @table_items); + my @table_items = + map { &html_item_state( $_, $webname_or_object_type ) } @objects; + $h_list .= + &table_it( $main::config_parms{ 'html_table_size' . $Http{format} }, + 0, 0, @table_items ); return $h_list; } - # List Voice_Cmds, by Category - if (@object_list = &list_objects_by_webname($webname_or_object_type)) { + # List Voice_Cmds, by Category + if ( @object_list = &list_objects_by_webname($webname_or_object_type) ) { $h_list .= "\n"; - $h_list .= &widgets('all', $webname_or_object_type); + $h_list .= &widgets( 'all', $webname_or_object_type ); $h_list .= &html_command_table(@object_list) if @object_list; return $h_list; } } - sub table_it { - my ($cols, $border, $space, @items) = @_; + my ( $cols, $border, $space, @items ) = @_; - my $h_list .= qq[\n]; + my $h_list .= + qq[
    \n]; my $num = 0; for my $item (@items) { - if ($num == 0) { - # Check to see if it already specs a row - if ($item =~ /^\\n]; } $h_list .= $item . "\n"; - if (++$num == $cols) { + if ( ++$num == $cols ) { $h_list .= "\n\n"; $num = 0; } } - # do this so we don't throw off the table cell sizes if the number of items is not divisable -# while ($num lt $cols) { -# $h_list .= qq[]; -# $h_list .= qq[]; -# $num++; -# } -# $h_list .= "\n
    \n"; + + # do this so we don't throw off the table cell sizes if the number of items is not divisable + # while ($num lt $cols) { + # $h_list .= qq[]; + # $h_list .= qq[ ]; + # $num++; + # } + # $h_list .= "\n\n"; $h_list .= "\n"; return $h_list; } sub html_command_table { my (@object_list) = @_; - my ($html, @htmls); + my ( $html, @htmls ); my $list_count = 0; - my ($msagent_cmd1, $msagent_script1, $msagent_script2 ); - - my @objects = map{&get_object_by_name($_)} @object_list; - - # Sort by sort field, then filename, then object name - for my $object (sort {($a->{order} and $b->{order} and $a->{order} cmp $b->{order}) or - ($a->{filename} cmp $b->{filename}) or - (exists $a->{text} and exists $b->{text} and $a->{text} cmp $b->{text})} @objects) { + my ( $msagent_cmd1, $msagent_script1, $msagent_script2 ); + + my @objects = map { &get_object_by_name($_) } @object_list; + + # Sort by sort field, then filename, then object name + for my $object ( + sort { + ( $a->{order} and $b->{order} and $a->{order} cmp $b->{order} ) + or ( $a->{filename} cmp $b->{filename} ) + or ( exists $a->{text} + and exists $b->{text} + and $a->{text} cmp $b->{text} ) + } @objects + ) + { my $object_name = $object->{object_name}; my $state_now = $object->{state}; my $filename = $object->{filename}; my $text = $object->{text}; - next unless $text; # Only do voice items + next unless $text; # Only do voice items next if $$object{hidden}; $list_count++; - # Find the states and create the test label - # - pick the first {a,b,c} phrase enumeration + # Find the states and create the test label + # - pick the first {a,b,c} phrase enumeration $text =~ s/\{(.+?),.+?\}/$1/g; - my ($prefix, $states, $suffix, $h_text, $text_cmd, $ol_info, $state_log, $ol_state_log); - ($prefix, $states, $suffix) = $text =~ /^(.*)\[(.+?)\](.*)$/; - $states = '' unless $states; # Avoid -w uninitialized values error + my ( $prefix, $states, $suffix, $h_text, $text_cmd, $ol_info, + $state_log, $ol_state_log ); + ( $prefix, $states, $suffix ) = $text =~ /^(.*)\[(.+?)\](.*)$/; + $states = '' unless $states; # Avoid -w uninitialized values error $suffix = '' unless $states; my @states = split ',', $states; -# my $states_with_select = @states > $config_parms{'html_category_select' . $Http{format}}; - my $states_with_select = length("@states") > $config_parms{'html_select_length' . $Http{format}}; - # Do the filename entry - push @htmls, qq[$filename\n] if $main::config_parms{'html_category_filename' . $Http{format}}; + # my $states_with_select = @states > $config_parms{'html_category_select' . $Http{format}}; + my $states_with_select = length("@states") > + $config_parms{ 'html_select_length' . $Http{format} }; + + # Do the filename entry + push @htmls, qq[$filename\n] + if $main::config_parms{ 'html_category_filename' . $Http{format} }; - # Build the info and statelog overlib strings - # - Netscape only supports onmouse over on hrefs :( - # - Building a dummy href for Netscap only kind of works, so lets skip it. -# $ol_info .= qq[{info}; - $ol_info = "$prefix ... $suffix" if !$ol_info and ($prefix or $suffix); - $ol_info = $text unless $ol_info; + $ol_info = "$prefix ... $suffix" + if !$ol_info and ( $prefix or $suffix ); + $ol_info = $text unless $ol_info; $ol_info = "$filename: $ol_info"; $ol_info =~ s/\'/\\\'/g; $ol_info =~ s/\"/\\\'/g; my $height = 20; - if ($states_with_select and $html_info_overlib) { - $ol_info .= '

  • ' . join ('
  • ', @states); + if ( $states_with_select and $html_info_overlib ) { + $ol_info .= '
  • ' . join( '
  • ', @states ); $height += 20 * @states; } my $row = $list_count; - $row /= 2 if $main::config_parms{'html_category_cols' . $Http{format}} == 2; + $row /= 2 + if $main::config_parms{ 'html_category_cols' . $Http{format} } == + 2; $height = $row * 25 if $row * 25 < $height; -# my $ol_pos = ($list_count > 5) ? 'ABOVE, HEIGHT, $height' : 'RIGHT'; -# my $ol_pos = "ABOVE, HEIGHT, $height"; + + # my $ol_pos = ($list_count > 5) ? 'ABOVE, HEIGHT, $height' : 'RIGHT'; + # my $ol_pos = "ABOVE, HEIGHT, $height"; my $ol_pos = "BELOW, HEIGHT, $height"; - $ol_info = qq[onMouseOver="overlib('$ol_info', $ol_pos)" onMouseOut="nd();"]; + $ol_info = + qq[onMouseOver="overlib('$ol_info', $ol_pos)" onMouseOut="nd();"]; - # Summarize state log entries - unless ($main::config_parms{'html_category_states' . $Http{format}}) { + # Summarize state log entries + unless ( + $main::config_parms{ 'html_category_states' . $Http{format} } ) + { my @states_log = state_log $object; - while (my $state = shift @states_log) { - if (my ($date, $time, $state) = $state =~ /(\S+) (\S+ *[APM]{0,2}) *(.*)/) { + while ( my $state = shift @states_log ) { + if ( my ( $date, $time, $state ) = + $state =~ /(\S+) (\S+ *[APM]{0,2}) *(.*)/ ) + { $ol_state_log .= "
  • $date $time $state "; } } $ol_state_log = "unknown" unless $ol_state_log; - $ol_state_log = qq[onMouseOver="overlib('$ol_state_log', RIGHT, WIDTH, 250 )" onMouseOut="nd();"]; + $ol_state_log = + qq[onMouseOver="overlib('$ol_state_log', RIGHT, WIDTH, 250 )" onMouseOut="nd();"]; } } - # Put in a dummy link, so we can get netscape state_log info - if ($config_parms{'html_info' . $Http{format}} eq 'overlib_link') { -# $html = qq[info
    ]; - $html = qq[info
    ]; - $html .= qq[log ]; + # Put in a dummy link, so we can get netscape state_log info + if ( $config_parms{ 'html_info' . $Http{format} } eq 'overlib_link' ) { + + # $html = qq[info
    ]; + $html = + qq[info
    ]; + $html .= + qq[log ]; push @htmls, qq[$html\n]; } - - # Do the icon entry - if ($main::config_parms{'html_category_icons' . $Http{format}} and - my $h_icon = &html_find_icon_image($object, 'voice')) { -# my $alt = $object->{info} . " ($h_icon)"; + # Do the icon entry + if ( $main::config_parms{ 'html_category_icons' . $Http{format} } + and my $h_icon = &html_find_icon_image( $object, 'voice' ) ) + { + # my $alt = $object->{info} . " ($h_icon)"; my $alt = $h_icon; - $alt =~ s/.*?([^\/]+)\..*/$1/; # Use just the base file name - $html = qq[\n]; -# $html = qq[$h_icon]; + $alt =~ s/.*?([^\/]+)\..*/$1/; # Use just the base file name + $html = + qq[\n]; + + # $html = qq[$h_icon]; } else { $html = qq[\n]; } - # Start the form before the icon - # - outside of td so the table is shorter - # - allows the icon to be a submit - my $form = qq[
    \n]; + # Start the form before the icon + # - outside of td so the table is shorter + # - allows the icon to be a submit + my $form = + qq[\n]; - # Icon button - push @htmls, qq[$form $html\n]; + # Icon button + push @htmls, + qq[$form $html\n]; - # Now do the main text entry - my $width = ($main::config_parms{'html_category_cols' . $Http{format}} == 1) ? "width='100%'" : ''; - $html = qq[ ]; + # Now do the main text entry + my $width = + ( $main::config_parms{ 'html_category_cols' . $Http{format} } == 1 ) + ? "width='100%'" + : ''; + $html = qq[ ]; $html .= qq[$prefix] if $prefix; - my $web_style = get_web_style $object; - if ( !defined $web_style ) { - if ( $states_with_select ) { - $web_style = "dropdown"; - } - elsif ( $states ) { - $web_style = "url"; - } - } + my $web_style = get_web_style $object; + if ( !defined $web_style ) { + if ($states_with_select) { + $web_style = "dropdown"; + } + elsif ($states) { + $web_style = "url"; + } + } - # Use a SELECT dropdown with 4 or more states + # Use a SELECT dropdown with 4 or more states my $currState = state $object; - if ($web_style eq "dropdown") { + if ( $web_style eq "dropdown" ) { $html .= qq[\n]; } elsif ( $web_style eq "radio" ) { -# $html .= qq[
    \n]; - $html=''; + $html = ''; - # Do the states_log entry - if ($main::config_parms{'html_category_states' . $Http{format}}) { - if (my ($date, $time, $state) = (state_log $object)[0] =~ /(\S+) (\S+) *(.*)/) { - $state_log = "$date $time $state"; + # Do the states_log entry + if ( $main::config_parms{ 'html_category_states' . $Http{format} } ) { + if ( my ( $date, $time, $state ) = + ( state_log $object)[0] =~ /(\S+) (\S+) *(.*)/ ) + { + $state_log = + "$date $time $state"; } else { $state_log = "unknown"; } - push @htmls, qq[$state_log\n\n]; + push @htmls, + qq[$state_log\n\n]; } - # Include MsAgent VR commands -# minijeff.Commands.Add "ltOfficeLight", "Control Office Light","Turn ( on | off ) office light", True, True + # Include MsAgent VR commands + # minijeff.Commands.Add "ltOfficeLight", "Control Office Light","Turn ( on | off ) office light", True, True my $msagent_id = substr $object_name, 1; -# $msagent_script1 .= qq[minijeff.Commands.Add "Run_Command", "$text", "$msagent_cmd1", True, True\n]; -# $msagent_script2 .= qq[Case "$msagent_id"\n $msagent_id\n]; -# $msagent_script1 .= qq[minijeff.Commands.Add "$msagent_id", "$text", "$msagent_cmd1", True, True\n]; - $msagent_cmd1 =~ s/\[\]//; # Drop [] on stateless commands + + # $msagent_script1 .= qq[minijeff.Commands.Add "Run_Command", "$text", "$msagent_cmd1", True, True\n]; + # $msagent_script2 .= qq[Case "$msagent_id"\n $msagent_id\n]; + # $msagent_script1 .= qq[minijeff.Commands.Add "$msagent_id", "$text", "$msagent_cmd1", True, True\n]; + $msagent_cmd1 =~ s/\[\]//; # Drop [] on stateless commands my $msagent_cmd2 = $msagent_cmd1; $msagent_cmd2 =~ s/\|/,/g; - $msagent_script1 .= qq[minijeff.Commands.Add "$msagent_id", "$msagent_cmd2", "$msagent_cmd1", True, True\n]; - $msagent_script2 .= qq[Case "$msagent_id"\n Run_Command(UserInput.voice)\n]; - } - - # Create final html - # moved the target option down to form and a tags to be compatible with IE7, dn -# $html = "\n"; - $html = qq[
    \n] . - qq[\n] . - $html if $html_info_overlib; - - if ($Http{'User-Agent'} =~ /^MS/ and $Cookies{msagent} and $main::config_parms{'html_msagent_script_vr' . $Http{format}}) { - my $msagent_file = file_read "$config_parms{'html_dir' . $Http{format}}/$config_parms{'html_msagent_script_vr' . $Http{format}}"; + $msagent_script1 .= + qq[minijeff.Commands.Add "$msagent_id", "$msagent_cmd2", "$msagent_cmd1", True, True\n]; + $msagent_script2 .= + qq[Case "$msagent_id"\n Run_Command(UserInput.voice)\n]; + } + + # Create final html + # moved the target option down to form and a tags to be compatible with IE7, dn + # $html = "\n"; + $html = + qq[
    \n] + . qq[\n] + . $html + if $html_info_overlib; + + if ( $Http{'User-Agent'} =~ /^MS/ + and $Cookies{msagent} + and $main::config_parms{ 'html_msagent_script_vr' . $Http{format} } ) + { + my $msagent_file = file_read + "$config_parms{'html_dir' . $Http{format}}/$config_parms{'html_msagent_script_vr' . $Http{format}}"; $msagent_file =~ s//$msagent_script1/; $msagent_file =~ s//$msagent_script2/; $html = $msagent_file . $html; } my $cols = 2; - $cols += 1 if $main::config_parms{'html_category_filename' . $Http{format}}; - $cols += 1 if $main::config_parms{'html_category_states' . $Http{format}}; - $cols += 1 if $main::config_parms{'html_info' . $Http{format}} eq 'overlib_link'; - $cols *= 2 if $main::config_parms{'html_category_cols' . $Http{format}} == 2; - - return $html . &table_it($cols, $main::config_parms{'html_category_border' . $Http{format}}, $main::config_parms{'html_category_cellsp' . $Http{format}}, @htmls); -} - - # Return html for 1 item + $cols += 1 + if $main::config_parms{ 'html_category_filename' . $Http{format} }; + $cols += 1 if $main::config_parms{ 'html_category_states' . $Http{format} }; + $cols += 1 + if $main::config_parms{ 'html_info' . $Http{format} } eq 'overlib_link'; + $cols *= 2 + if $main::config_parms{ 'html_category_cols' . $Http{format} } == 2; + + return $html + . &table_it( + $cols, + $main::config_parms{ 'html_category_border' . $Http{format} }, + $main::config_parms{ 'html_category_cellsp' . $Http{format} }, + @htmls + ); +} + +# Return html for 1 item sub html_item { my ($name) = @_; my $object = &get_object_by_name($name); - if (UNIVERSAL::isa($object, 'Voice_Cmd')) { + if ( UNIVERSAL::isa( $object, 'Voice_Cmd' ) ) { return &html_command_table($name); } else { - return &table_it(1, 1, 0, &html_item_state($object, $name)); + return &table_it( 1, 1, 0, &html_item_state( $object, $name ) ); } } - # List current object state +# List current object state sub html_item_state { - my ($object, $object_type) = @_; + my ( $object, $object_type ) = @_; my $object_name = $object->{object_name}; my $object_name2 = &pretty_object_name($object_name); - my $isa_X10 = UNIVERSAL::isa($object, 'X10_Item'); - my $isa_EIB2 = UNIVERSAL::isa($object, 'EIB2_Item'); - - # If not a state item, just list it - unless ($isa_X10 or UNIVERSAL::isa($object, 'Group') or exists $object->{state} or $object->{states}) { + my $isa_X10 = UNIVERSAL::isa( $object, 'X10_Item' ); + my $isa_EIB2 = UNIVERSAL::isa( $object, 'EIB2_Item' ); + + # If not a state item, just list it + unless ( $isa_X10 + or UNIVERSAL::isa( $object, 'Group' ) + or exists $object->{state} + or $object->{states} ) + { return qq[$object_name2\n]; } - my $filename = $object->{filename}; - my $state_now = $object->{state}; + my $filename = $object->{filename}; + my $state_now = $object->{state}; my $html; - $state_now = '' unless defined($state_now); # Avoid -w uninitialized value msg + $state_now = '' + unless defined($state_now); # Avoid -w uninitialized value msg - # If >2 possible states, add a Select pull down form + # If >2 possible states, add a Select pull down form my @states; - @states = @{$object->{states}} if $object->{states}; + @states = @{ $object->{states} } if $object->{states}; @states = split ',', $config_parms{x10_menu_states} if $isa_X10; - @states = qw(on off) if UNIVERSAL::isa($object, 'X10_Appliance'); + @states = qw(on off) if UNIVERSAL::isa( $object, 'X10_Appliance' ); - my $use_select = 1 if @states > 2 and length("@states") > $config_parms{'html_select_length' . $Http{format}}; + my $use_select = 1 + if @states > 2 + and length("@states") > + $config_parms{ 'html_select_length' . $Http{format} }; if ($use_select) { - # Some browsers (e.g. Audrey) do not have full url in Referer :( - my $referer = ($Http{Referer} =~ /html$/) ? 'referer' : "&html_list($object_type)"; + + # Some browsers (e.g. Audrey) do not have full url in Referer :( + my $referer = + ( $Http{Referer} =~ /html$/ ) + ? 'referer' + : "&html_list($object_type)"; $html .= qq[
    \n]; - $html .= qq[\n]; # So we can uncheck buttons + $html .= + qq[\n] + ; # So we can uncheck buttons } - # Find icon to show state, if not found show state_now in text. - # - icon is also used to show state log - $html .= qq["; + # Find icon to show state, if not found show state_now in text. + # - icon is also used to show state log + $html .= + qq["; - if (my $h_icon = &html_find_icon_image($object, $object_type)) { + if ( my $h_icon = &html_find_icon_image( $object, $object_type ) ) { $html .= qq[$object_name]; } - elsif ($state_now ne '') { - my $temp = $state_now; - $temp = substr($temp, 0, 8) . '..' if length $temp > 8; - $html .= $temp . ' '; + elsif ( $state_now ne '' ) { + my $temp = $state_now; + $temp = substr( $temp, 0, 8 ) . '..' if length $temp > 8; + $html .= $temp . ' '; } else { - $html .= qq[no_state]; + $html .= + qq[no_state]; } $html .= qq[\n]; - # Add brighten/dim arrows on X10 Items + # Add brighten/dim arrows on X10 Items $html .= qq[]; - if (($isa_X10 and !UNIVERSAL::isa($object, 'X10_Appliance')) || $isa_EIB2) { + if ( ( $isa_X10 and !UNIVERSAL::isa( $object, 'X10_Appliance' ) ) + || $isa_EIB2 ) + { - # Some browsers (e.g. Audrey) do not have full url in Referer :( - my $referer = ($Http{Referer} =~ /html$/) ? 'referer' : "&html_list($object_type)"; + # Some browsers (e.g. Audrey) do not have full url in Referer :( + my $referer = + ( $Http{Referer} =~ /html$/ ) + ? 'referer' + : "&html_list($object_type)"; - # Note: Use hex 2B = +, as + means spaces in most urls - $html .= qq[+ ]; - $html .= qq[ - ]; + # Note: Use hex 2B = +, as + means spaces in most urls + $html .= + qq[+ ]; + $html .= + qq[ - ]; } - # Add Select states + # Add Select states if ($use_select) { $html .= qq[\n]; } if (@states) { - # Find toggle state + + # Find toggle state my $state_toggle; - if ($object_type eq 'Weather_Item') { + if ( $object_type eq 'Weather_Item' ) { } - elsif ($state_now eq ON or $state_now =~ /^[\+\-]?\d/) { + elsif ( $state_now eq ON or $state_now =~ /^[\+\-]?\d/ ) { $state_toggle = OFF; } - elsif ($state_now eq OFF or grep $_ eq ON, @states) { + elsif ( $state_now eq OFF or grep $_ eq ON, @states ) { $state_toggle = ON; } if ($state_toggle) { - # Some browsers (e.g. Audrey) do not have full url in Referer :( - my $referer = ($Http{Referer} =~ /html$/) ? 'referer' : "&html_list($object_type)"; - $html .= qq[$object_name2]; + + # Some browsers (e.g. Audrey) do not have full url in Referer :( + my $referer = + ( $Http{Referer} =~ /html$/ ) + ? 'referer' + : "&html_list($object_type)"; + $html .= + qq[$object_name2]; } else { $html .= $object_name2; @@ -2506,15 +2952,22 @@ sub html_item_state { else { $html .= $object_name2; } -# else { + + # else { unless ($use_select) { for my $state (@states) { next unless $state; my $state_url = &escape($state); my $state_short = substr $state, 0, 15; - # Some browsers (e.g. Audrey) do not have full url in Referer :( - my $referer = ($Http{Referer} =~ /html$/) ? 'referer' : "&html_list($object_type)"; - $html .= qq[ $state_short]; } + + # Some browsers (e.g. Audrey) do not have full url in Referer :( + my $referer = + ( $Http{Referer} =~ /html$/ ) + ? 'referer' + : "&html_list($object_type)"; + $html .= + qq[ $state_short]; + } } $html .= qq[]; @@ -2523,12 +2976,13 @@ sub html_item_state { } $Password_Allow{'&html_state_log'} = 'anyone'; + sub html_state_log { my ($object_name) = @_; - my $object = &get_object_by_name($object_name); - my $object_name2 = &pretty_object_name($object_name); - my $html = "$object_name2 states
    \n"; - for my $state (state_log $object) { + my $object = &get_object_by_name($object_name); + my $object_name2 = &pretty_object_name($object_name); + my $html = "$object_name2 states
    \n"; + for my $state ( state_log $object) { $html .= "
  • $state
    • \n" if $state; } return $html . "\n"; @@ -2536,18 +2990,19 @@ sub html_state_log { sub html_info { my ($object_name) = @_; - my $object = &get_object_by_name($object_name); - my $object_name2 = &pretty_object_name($object_name); - my $html = "$object_name2 info
    \n"; + my $object = &get_object_by_name($object_name); + my $object_name2 = &pretty_object_name($object_name); + my $html = "$object_name2 info
    \n"; $html .= $object->{info}; return $html; } sub html_active_href { - my($url, $text) = @_; + my ( $url, $text ) = @_; return qq[$text]; - # Netscape has problems with this when - # used with the hide-show javascript in main.shtml / top.html + + # Netscape has problems with this when + # used with the hide-show javascript in main.shtml / top.html return qq[ $Password_Allow{'&dir_index'} = 'anyone'; + sub dir_index { - my ($dir_html, $sortby, $reverse, $filter, $limit) = @_; + my ( $dir_html, $sortby, $reverse, $filter, $limit ) = @_; -# print "dbx in dir_index for $dir_html\n"; + # print "dbx in dir_index for $dir_html\n"; - $filter = '' unless $filter; # Avoid uninit warnings - $sortby = '' unless $sortby; # Avoid uinit warnings - my $reverse2 = ($reverse) ? 0 : 1; - my $sort_order = ($reverse) ? '+' : '-' ; - my ($dir) = &http_get_local_file($dir_html); - my $dir_tr = $dir_html; + $filter = '' unless $filter; # Avoid uninit warnings + $sortby = '' unless $sortby; # Avoid uinit warnings + my $reverse2 = ($reverse) ? 0 : 1; + my $sort_order = ($reverse) ? '+' : '-'; + my ($dir) = &http_get_local_file($dir_html); + my $dir_tr = $dir_html; $dir_tr =~ s/\//\%2F/g; - opendir DIR, $dir or print "http_server: Could not open dir_index for $dir_html dir=$dir: $!\n"; + opendir DIR, $dir + or print + "http_server: Could not open dir_index for $dir_html dir=$dir: $!\n"; my @files = sort readdir DIR; close DIR; - @files = grep /$filter/, @files if $filter; # Drop out files if requested + @files = grep /$filter/, @files if $filter; # Drop out files if requested $filter =~ s/\\/\%5C/g; - my $html = qq[\n]; - $html .= qq[\n]; - $html .= qq[\n]; - $html .= qq[\n]; - $html .= qq[\n]; + my $html = + qq[
    $sort_order Sort by Name$sort_order Sort by Type$sort_order Sort by Size$sort_order Sort by Date
    \n]; + $html .= + qq[\n]; + $html .= + qq[\n]; + $html .= + qq[\n]; + $html .= + qq[\n]; my %file_data; for my $file (@files) { - ($file_data{$file}{size}, $file_data{$file}{date}) = (stat("$dir/$file"))[7,9]; + ( $file_data{$file}{size}, $file_data{$file}{date} ) = + ( stat("$dir/$file") )[ 7, 9 ]; my ($type) = $file =~ /(\.[^\.]+)$/; $type = '' unless $type; $type = 'Directory' if -d "$dir/$file"; $file_data{$file}{type} = $type; -# $file_data{$file}{type} = '' $1 if $file =~ /(\.[^\.]+)$/; -# if ($file =~ /(\.[^\.]+)$/) { -# $file_data{$file}{type} = $1; -# } -# else { -# $file_data{$file}{type} = ''; -# } + # $file_data{$file}{type} = '' $1 if $file =~ /(\.[^\.]+)$/; + # if ($file =~ /(\.[^\.]+)$/) { + # $file_data{$file}{type} = $1; + # } + # else { + # $file_data{$file}{type} = ''; + # } } - if ($sortby eq 'date' or $sortby eq 'size') { - @files = sort {$file_data{$a}{$sortby} <=> $file_data{$b}{$sortby} or $a cmp $b} @files; + if ( $sortby eq 'date' or $sortby eq 'size' ) { + @files = sort { + $file_data{$a}{$sortby} <=> $file_data{$b}{$sortby} + or $a cmp $b + } @files; } - elsif ($sortby eq 'type') { - @files = sort {$file_data{$a}{$sortby} cmp $file_data{$b}{$sortby} or $a cmp $b} @files; + elsif ( $sortby eq 'type' ) { + @files = sort { + $file_data{$a}{$sortby} cmp $file_data{$b}{$sortby} + or $a cmp $b + } @files; } @files = reverse @files if $reverse; my $i = 0; for my $file (@files) { my $file_date = localtime $file_data{$file}{date}; - my $file_ref = $file; + my $file_ref = $file; $file_ref =~ s/ /%20/g; $html .= "\n"; $html .= "\n"; $html .= "\n"; $html .= "\n"; - last if $limit and $i++ > $limit; + last if $limit and $i++ > $limit; } return $html . "
    $sort_order Sort by Name$sort_order Sort by Type$sort_order Sort by Size$sort_order Sort by Date
    $file$file_data{$file}{type}$file_data{$file}{size}$file_date
    \n"; @@ -3243,8 +3764,7 @@ sub wml_page { return $wml; } - -return 1; # Make require happy +return 1; # Make require happy # Example on updateing 2 frames at once # |; -$html .= qq|| if $parms{date}; - -if ($parms{jclock1} or $parms{jclock2}) { - $html .= &file_read("$config_parms{html_dir}/bin/clock1.js") if $parms{jclock1}; - $html .= &file_read("$config_parms{html_dir}/bin/clock2.js") if $parms{jclock2}; +$html .= qq|| + if $parms{date}; + +if ( $parms{jclock1} or $parms{jclock2} ) { + $html .= &file_read("$config_parms{html_dir}/bin/clock1.js") + if $parms{jclock1}; + $html .= &file_read("$config_parms{html_dir}/bin/clock2.js") + if $parms{jclock2}; $html .= "\n"; $html .= qq[\n]; -# $html .= qq[\n]; + + # $html .= qq[\n]; $html =~ s/font size='\d'/font size='$fontsize'/ if $fontsize != 2; } else { $html .= "\n"; $html .= qq[\n]; -# $html .= qq[\n]; + + # $html .= qq[\n]; } $html .= qq[\n]; -$html .= qq[\n]; +$html .= + qq[
    \n]; $html .= qq[\n"; -if ($parms{date}) { - $html .= qq[\n]; +if ( $parms{date} ) { + $html .= + qq[\n]; } -if ($parms{clock}) { +if ( $parms{clock} ) { $html .= qq[\n]; } -if ($parms{jclock1}) { - $html .= qq[\n]; +if ( $parms{jclock1} ) { + $html .= + qq[\n]; } -if ($parms{jclock2}) { - $html .= qq[\n]; +if ( $parms{jclock2} ) { + $html .= + qq[\n]; } $html .= qq[
    $fontstart\n]; - - # Do parms in specified order +# Do parms in specified order for my $parm (@parms) { - # Allow for a reference mintute, so we can verify against javaclock - if ($parm eq 'minute') { + # Allow for a reference mintute, so we can verify against javaclock + if ( $parm eq 'minute' ) { $html .= qq[$Minute]; } - # Allow for sun (auto-pick), sunrise, or sunset - elsif ($parm =~ /sun/) { - if ($parm eq 'sun') { - $parm = (time_less_than "$Time_Sunrise + 2:00" or - time_greater_than "$Time_Sunset + 2:00") ? 'sunrise' : 'sunset'; + + # Allow for sun (auto-pick), sunrise, or sunset + elsif ( $parm =~ /sun/ ) { + if ( $parm eq 'sun' ) { + $parm = ( + time_less_than "$Time_Sunrise + 2:00" + or time_greater_than "$Time_Sunset + 2:00" + ) ? 'sunrise' : 'sunset'; } - if ($parm eq 'sunrise') { - $html .= qq[  Rise $Time_Sunrise\n]; + if ( $parm eq 'sunrise' ) { + $html .= + qq[  Rise $Time_Sunrise\n]; } else { - $html .= qq[  Set $Time_Sunset\n]; + $html .= + qq[  Set $Time_Sunset\n]; } } - elsif ($parm eq 'mode') { + elsif ( $parm eq 'mode' ) { $html .= qq[  ]; - if ($Save{mode} ne 'normal') { + if ( $Save{mode} ne 'normal' ) { $html .= qq[$Save{mode}\n]; } else { $html .= qq[$Save{mode}\n]; } - use vars '$mh_volume'; # In case we don't have mh_sound + use vars '$mh_volume'; # In case we don't have mh_sound if ($mh_volume) { my $sl_vol = state $mh_volume; $html .= qq[($sl_vol%)\n]; } } - # This can be set by an mp3 player script - elsif ($parm eq 'playing') { + + # This can be set by an mp3 player script + elsif ( $parm eq 'playing' ) { my $html_playing = $Save{NowPlaying}; $html .= qq[$html_playing]; } - elsif ($parm eq 'email') { - $Save{email_flag}= '' unless $Save{email_flag}; - $html .= qq[ $Save{email_flag}\n]; + elsif ( $parm eq 'email' ) { + $Save{email_flag} = '' unless $Save{email_flag}; + $html .= + qq[ $Save{email_flag}\n]; } - elsif ($parm eq 'weather') { + elsif ( $parm eq 'weather' ) { $Weather{Summary_Short} = '' unless $Weather{Summary_Short}; - $html .= qq[  $Weather{Summary_Short}\n]; + $html .= + qq[  $Weather{Summary_Short}\n]; } - elsif ($parm eq 'weather_long') { + elsif ( $parm eq 'weather_long' ) { $Weather{Summary} = '' unless $Weather{Summary}; - $html .= qq[  $Weather{Summary}\n]; + $html .= + qq[  $Weather{Summary}\n]; } - elsif ($parm eq 'wind') { + elsif ( $parm eq 'wind' ) { my $html_wind = $Weather{Wind}; $html_wind = '' unless $html_wind; $html_wind =~ s/from the/ /; - $html .= qq[  $html_wind\n]; + $html .= + qq[  $html_wind\n]; } - # Allow for user defined html (e.g. code/bruce/web_sub.pl) - elsif ($parm eq 'web_status_line') { + # Allow for user defined html (e.g. code/bruce/web_sub.pl) + elsif ( $parm eq 'web_status_line' ) { $html .= &web_status_line(); } @@ -140,19 +156,22 @@ $html .= "$fontstart$Date_Now$fontstart$Date_Now${fontstart} $Time_Now
    ${fontstart} $Time_Now
    ${fontstart} $Time_Now
    \n]; -return &html_page('', $html, ' '); +return &html_page( '', $html, ' ' ); diff --git a/web/bin/status_panel.pl b/web/bin/status_panel.pl index f44458e78..3370f3836 100644 --- a/web/bin/status_panel.pl +++ b/web/bin/status_panel.pl @@ -5,27 +5,29 @@ # See bin/mh/mh.ini for more info my $argv = join '&', @ARGV; -my @parms = split('&', $config_parms{html_status_line}); +my @parms = split( '&', $config_parms{html_status_line} ); my $parms = "@parms"; -my %parms = map {$_, 1} @parms; +my %parms = map { $_, 1 } @parms; my $html = qq[]; - # Do parms in specified order for my $parm (@parms) { - # Allow for a reference mintute, so we can verify against javaclock - if ($parm eq 'minute') { + # Allow for a reference mintute, so we can verify against javaclock + if ( $parm eq 'minute' ) { $html .= qq[

    Current Minute: $Minute

    \n]; } - # Allow for sun (auto-pick), sunrise, or sunset - elsif ($parm =~ /sun/) { - if ($parm eq 'sun') { - $parm = (time_less_than "$Time_Sunrise + 2:00" or - time_greater_than "$Time_Sunset + 2:00") ? 'sunrise' : 'sunset'; + + # Allow for sun (auto-pick), sunrise, or sunset + elsif ( $parm =~ /sun/ ) { + if ( $parm eq 'sun' ) { + $parm = ( + time_less_than "$Time_Sunrise + 2:00" + or time_greater_than "$Time_Sunset + 2:00" + ) ? 'sunrise' : 'sunset'; } - if ($parm eq 'sunrise') { + if ( $parm eq 'sunrise' ) { $html .= qq[

    Sunrise: $Time_Sunrise

    \n]; } else { @@ -33,60 +35,62 @@ } } - elsif ($parm eq 'mode') { + elsif ( $parm eq 'mode' ) { $html .= qq[

    Mode: ]; - if ($Save{mode} ne 'normal') { + if ( $Save{mode} ne 'normal' ) { $html .= qq[$Save{mode}]; } else { $html .= qq[$Save{mode}]; } - $html .= qq[]; - use vars '$mh_volume'; # In case we don't have mh_sound + $html .= qq[]; + use vars '$mh_volume'; # In case we don't have mh_sound if ($mh_volume) { my $sl_vol = state $mh_volume; $html .= qq[ (Vol: $sl_vol%)]; } $html .= qq[

    \n]; } - # This can be set by an mp3 player script - elsif ($parm eq 'playing') { + + # This can be set by an mp3 player script + elsif ( $parm eq 'playing' ) { my $html_playing = $Save{NowPlaying}; $html .= qq[

    Playing: $html_playing

    \n]; } - elsif ($parm eq 'email') { - $Save{email_flag}= 'Unavailable' unless $Save{email_flag}; + elsif ( $parm eq 'email' ) { + $Save{email_flag} = 'Unavailable' unless $Save{email_flag}; $html .= qq[

    Mail: $Save{email_flag}

    \n]; } - elsif ($parm eq 'weather') { + elsif ( $parm eq 'weather' ) { $Weather{Summary_Short} = 'Unavailable' unless $Weather{Summary_Short}; $html .= qq[

    Temp: $Weather{Summary_Short}

    \n]; } - elsif ($parm eq 'weather_long') { + elsif ( $parm eq 'weather_long' ) { $Weather{Summary} = 'Unavailable' unless $Weather{Summary}; + #$html .= qq[

    Weather: $Weather{Summary}

    \n]; } - elsif ($parm eq 'wind') { + elsif ( $parm eq 'wind' ) { my $html_wind = $Weather{Wind}; $html_wind = 'Unavailable' unless $html_wind; $html_wind =~ s/from the/ /; $html .= qq[

    Wind: $html_wind

    \n]; } - # Allow for user defined html (e.g. code/bruce/web_sub.pl) - elsif ($parm eq 'web_status_line') { + # Allow for user defined html (e.g. code/bruce/web_sub.pl) + elsif ( $parm eq 'web_status_line' ) { $html .= &web_status_line(); } } -if ($parms{date}) { +if ( $parms{date} ) { $html .= qq[

    Date: $Date_Now, $Year

    \n]; } -if ($parms{clock}) { +if ( $parms{clock} ) { $html .= qq[

    Time: $Time_Now

    \n]; } diff --git a/web/bin/tagline.pl b/web/bin/tagline.pl index 5584744bb..4631f2d29 100644 --- a/web/bin/tagline.pl +++ b/web/bin/tagline.pl @@ -3,16 +3,15 @@ # Authority: anyone -if (-e "$config_parms{data_dir}/remarks/1100tags.txt"){ - @ARGV = "$config_parms{data_dir}/remarks/1100tags.txt"; +if ( -e "$config_parms{data_dir}/remarks/1100tags.txt" ) { + @ARGV = "$config_parms{data_dir}/remarks/1100tags.txt"; } -else{ - @ARGV = "$Pgm_Root/data/remarks/1100tags.txt"; +else { + @ARGV = "$Pgm_Root/data/remarks/1100tags.txt"; } my $tagline; -rand($.) < 1 && ($tagline=$_) while <>; +rand($.) < 1 && ( $tagline = $_ ) while <>; return $tagline; - diff --git a/web/bin/test_cgi.pl b/web/bin/test_cgi.pl index 3ccf9236b..c502e1d7d 100644 --- a/web/bin/test_cgi.pl +++ b/web/bin/test_cgi.pl @@ -6,29 +6,29 @@ print "

    Hello World from mh test_cgi.pl

    "; print "

    POST Data:

    \n

    "; -while (my ($key, $value) = each %HTTP_ARGV){ - print "$key=$value
    \n"; +while ( my ( $key, $value ) = each %HTTP_ARGV ) { + print "$key=$value
    \n"; } print "

    \n"; print "

    Query Data:

    \n

    "; -while (my ($key, $value) = each %Http){ - print "$key=$value
    \n"; +while ( my ( $key, $value ) = each %Http ) { + print "$key=$value
    \n"; } print "

    \n"; #print "

    HTTP Content:

    \n

    $HTTP_CONTENT

    \n\n"; open E, "> /tmp/e"; + #print E $HTTP_CONTENT; close E; - print "

    stdin\n
    \n";
 while () {
-	print "$_\n";
+    print "$_\n";
 }
-		
+
 print "
    \n"; - + print "\n"; diff --git a/web/bin/test_cgi_error.pl b/web/bin/test_cgi_error.pl index 1423a4118..164d4156c 100644 --- a/web/bin/test_cgi_error.pl +++ b/web/bin/test_cgi_error.pl @@ -4,6 +4,6 @@ This is an error -print "Content-Type: text/html\n\n"; + print "Content-Type: text/html\n\n"; print "

    Hello World from mh test_cgi.pl

    "; diff --git a/web/bin/test_error.pl b/web/bin/test_error.pl index ab88d193e..7b2d768fd 100644 --- a/web/bin/test_error.pl +++ b/web/bin/test_error.pl @@ -3,4 +3,4 @@ Give an error -return "Testing script errors"; + return "Testing script errors"; diff --git a/web/bin/triggers.pl b/web/bin/triggers.pl index c73b5f2e8..78d022c61 100644 --- a/web/bin/triggers.pl +++ b/web/bin/triggers.pl @@ -9,13 +9,13 @@ =cut use strict; -$^W = 0; # Avoid redefined sub msgs +$^W = 0; # Avoid redefined sub msgs -my ($function, @parms) = @ARGV; +my ( $function, @parms ) = @ARGV; #print "dbx a=@ARGV.\n"; -if ($function eq 'add') { +if ( $function eq 'add' ) { return &web_trigger_add(); } else { @@ -24,16 +24,18 @@ sub web_trigger_list { - &_triggers_save; # Check for changes to write out + &_triggers_save; # Check for changes to write out - # Create header and 'add a trigger' form + # Create header and 'add a trigger' form my $html = &html_header('Triggers Menu'); - my $form_trigger = &html_form_select('trigger1', 0, 'time_now', '', - qw(time_now time_cron time_random new_second new_minute new_hour $New_Hour $New_Day $New_Week $New_Month $New_Year)); + my $form_trigger = &html_form_select( 'trigger1', 0, 'time_now', '', + qw(time_now time_cron time_random new_second new_minute new_hour $New_Hour $New_Day $New_Week $New_Month $New_Year) + ); - my $form_code = &html_form_select('code1', 0, 'speak', '', - qw(speak play display print_log set run run_voice_cmd net_im_send net_mail_send get)); + my $form_code = &html_form_select( 'code1', 0, 'speak', '', + qw(speak play display print_log set run run_voice_cmd net_im_send net_mail_send get) + ); $html = qq| @@ -76,28 +78,40 @@ sub web_trigger_list { |; - # Add an index + # Add an index $html .= "    Refresh\n"; $html .= "Trigger Index: \n"; - for my $category ('OneShot', 'NoExpire', 'Disabled', 'Expired') { + for my $category ( 'OneShot', 'NoExpire', 'Disabled', 'Expired' ) { $html .= "$category\n"; } my $type_prev; - # Sort in indexed order - for my $name (sort {my $t1 = $triggers{$a}{type}; my $t2 = $triggers{$b}{type}; - $t1 = 0 if $t1 eq 'OneShot'; $t2 = 0 if $t2 eq 'OneShot'; - $t1 = 1 if $t1 eq 'NoExpire'; $t2 = 1 if $t2 eq 'NoExpire'; - $t1 cmp $t2 or lc $a cmp lc $b} keys %triggers) { - my ($trigger, $code, $type, $triggered, $trigger_error, $code_error) = trigger_get($name); - - if ($type_prev ne $type) { + # Sort in indexed order + for my $name ( + sort { + my $t1 = $triggers{$a}{type}; + my $t2 = $triggers{$b}{type}; + $t1 = 0 if $t1 eq 'OneShot'; + $t2 = 0 if $t2 eq 'OneShot'; + $t1 = 1 if $t1 eq 'NoExpire'; + $t2 = 1 if $t2 eq 'NoExpire'; + $t1 cmp $t2 or lc $a cmp lc $b + } keys %triggers + ) + { + + my ( $trigger, $code, $type, $triggered, $trigger_error, $code_error ) + = trigger_get($name); + + if ( $type_prev ne $type ) { $html .= "\n" if $type_prev; - $type_prev = $type; - $html .= "

    $type: (back to top)\n"; + $type_prev = $type; + $html .= + "

    $type: (back to top)\n"; $html .= qq|\n|; - $html .= "\n"; + $html .= + "\n"; } my $name2 = $name; @@ -107,69 +121,91 @@ sub web_trigger_list { $code =~ s/"/"/g; $html .= "\n"; - - $html .= &html_form_input_set_func('trigger_rename', '/bin/triggers.pl', $name, $name); + $html .= + "Copy\n"; + $html .= + " Delete\n"; + $html .= + " Run\n"; + + $html .= + &html_form_input_set_func( 'trigger_rename', '/bin/triggers.pl', + $name, $name ); $html .= qq|\n| if $trigger_error; - $html .= &html_form_input_set_func('trigger_set_trigger', '/bin/triggers.pl', $name, $trigger); + $html .= + &html_form_input_set_func( 'trigger_set_trigger', '/bin/triggers.pl', + $name, $trigger ); $html .= "\n" if $trigger_error; $html .= qq|\n| if $code_error; - $html .= &html_form_input_set_func('trigger_set_code', '/bin/triggers.pl', $name, $code); + $html .= + &html_form_input_set_func( 'trigger_set_code', '/bin/triggers.pl', + $name, $code ); $html .= "\n" if $code_error; - $html .= &html_form_select_set_func('trigger_set_type', '/bin/triggers.pl', $name, $type, - 'OneShot', 'NoExpire', 'Disabled', 'Expired'); + $html .= + &html_form_select_set_func( 'trigger_set_type', '/bin/triggers.pl', + $name, $type, 'OneShot', 'NoExpire', 'Disabled', 'Expired' ); if ($triggered) { - my $triggered_date = &time_date_stamp(7, $triggered) if $triggered; + my $triggered_date = &time_date_stamp( 7, $triggered ) + if $triggered; $html .= "\n"; } $html .= "\n\n"; - $html .= qq|\n\n\n| + $html .= + qq|\n\n\n| if $trigger_error; - $html .= qq|\n\n\n| + $html .= + qq|\n\n\n| if $code_error; } $html .= "
    NameTrigger EventAction CodeTypeLast Run
    NameTrigger EventAction CodeTypeLast Run
    "; - $html .= "Copy\n"; - $html .= " Delete\n"; - $html .= " Run$triggered_date
    Trigger Event Error: $trigger_error
    Trigger Event Error: $trigger_error
    Action Code Error: $code_error
    Action Code Error: $code_error
    \n"; - return &html_page('', $html); + return &html_page( '', $html ); } sub web_trigger_add { - # Allow un-authorized users to browse only (if listed in password_allow) - return &html_page('', 'Not authorized to make updates') unless $Authorized eq 'admin'; - # Process form + # Allow un-authorized users to browse only (if listed in password_allow) + return &html_page( '', 'Not authorized to make updates' ) + unless $Authorized eq 'admin'; + + # Process form if (@parms) { -# print "db p=@parms\n"; + + # print "db p=@parms\n"; my %p; for my $p (@parms) { $p{$1} = $2 if $p =~ /(.+?)=(.+)/; } - my $trigger = ($p{trigger1}) ? "$p{trigger1} '$p{trigger2}'" : $p{trigger2}; + my $trigger = + ( $p{trigger1} ) ? "$p{trigger1} '$p{trigger2}'" : $p{trigger2}; my $code; - if ($p{code1}) { - unless ($p{code1} eq 'set') { - $p{code2} =~ s/\'/\\'/g; - $p{code2} = "'$p{code2}'"; - } + if ( $p{code1} ) { + unless ( $p{code1} eq 'set' ) { + $p{code2} =~ s/\'/\\'/g; + $p{code2} = "'$p{code2}'"; + } $code = "$p{code1} $p{code2}"; } else { $code = $p{code2}; } -# print "db t=$trigger c=$code\n"; - &trigger_set($trigger, $code, $p{type}, $p{name}); + + # print "db t=$trigger c=$code\n"; + &trigger_set( $trigger, $code, $p{type}, $p{name} ); return &http_redirect('/bin/triggers.pl'); } - # Create form + + # Create form else { - my $html = "Add a trigger:

    \n"; + my $html = + "Add a trigger:\n"; $html .= qq|
    Name \n|; - $html .= qq|
    Trigger\n|; - $html .= qq|
    Event \n|; + $html .= + qq|
    Trigger\n|; + $html .= + qq|
    Event \n|; $html .= qq|
    Type |; $html .= qq|
    \n|; - return &html_page('', $html); + return &html_page( '', $html ); } } diff --git a/web/bin/tv_search.pl b/web/bin/tv_search.pl index 343f8f99f..474a27085 100644 --- a/web/bin/tv_search.pl +++ b/web/bin/tv_search.pl @@ -8,77 +8,63 @@ =cut #my ($string) = @ARGV; -my ($MyArgs)=""; -#$string =~ s/search=//; # Allow for ?string or ?search=string - - - my $i=0; - while (@ARGV[$i]) - { -# print @ARGV[$i] ."\n"; - my($param,$value)=split(/=/,@ARGV[$i]); - print "Param:$param Value:$value\n"; - if ($param eq "time" || $param eq "times") - { - $MyArgs .= " -times \"$value\" "; - } - if ($param eq "dates") - { - $MyArgs .= " -dates \"$value\" "; - } - if ($param eq "genre") - { - $MyArgs .= " -genre \"$value\" "; - } - if ($param eq "channel" || $param eq "channels" ) - { - $MyArgs .= " -channels \"$value\" "; - } - if ( ($param eq "search" || $param eq "keys") && length($value)>1 ) - { - $MyArgs .= " -keys \"$value\" "; - } - if ($param eq "keyfile") - { - $MyArgs .= " -keyfile \"$value\" "; - } - $i++; - } - if (! ($MyArgs =~ /channels/gi) ) - { - $MyArgs .= " -channels \"$config_parms{tv_my_favorites_channels}\" "; - } +my ($MyArgs) = ""; +#$string =~ s/search=//; # Allow for ?string or ?search=string +my $i = 0; +while ( @ARGV[$i] ) { + + # print @ARGV[$i] ."\n"; + my ( $param, $value ) = split( /=/, @ARGV[$i] ); + print "Param:$param Value:$value\n"; + if ( $param eq "time" || $param eq "times" ) { + $MyArgs .= " -times \"$value\" "; + } + if ( $param eq "dates" ) { + $MyArgs .= " -dates \"$value\" "; + } + if ( $param eq "genre" ) { + $MyArgs .= " -genre \"$value\" "; + } + if ( $param eq "channel" || $param eq "channels" ) { + $MyArgs .= " -channels \"$value\" "; + } + if ( ( $param eq "search" || $param eq "keys" ) && length($value) > 1 ) { + $MyArgs .= " -keys \"$value\" "; + } + if ( $param eq "keyfile" ) { + $MyArgs .= " -keyfile \"$value\" "; + } + $i++; +} +if ( !( $MyArgs =~ /channels/gi ) ) { + $MyArgs .= " -channels \"$config_parms{tv_my_favorites_channels}\" "; +} set_watch $f_tv_file; run qq[get_tv_info_ge $MyArgs -table]; -my ($count)=10; +my ($count) = 10; my $html = "There "; -while ($count >0) -{ - if ( changed $f_tv_file) - { - my $f_tv_info2 = "$config_parms{data_dir}/tv_info2.txt"; - my $summary = read_head $f_tv_file 6; - my ($show_count) = $summary =~ /Found (\d+)/; - - if ($show_count ==0) - { - $html = "Sorry nothing found "; - } - else - { - $html = file_read "$config_parms{data_dir}/tv_info2.html"; - } - - - $count =0; - } - $count =$count-1; - sleep(1); +while ( $count > 0 ) { + if ( changed $f_tv_file) { + my $f_tv_info2 = "$config_parms{data_dir}/tv_info2.txt"; + my $summary = read_head $f_tv_file 6; + my ($show_count) = $summary =~ /Found (\d+)/; + + if ( $show_count == 0 ) { + $html = "Sorry nothing found "; + } + else { + $html = file_read "$config_parms{data_dir}/tv_info2.html"; + } + + $count = 0; + } + $count = $count - 1; + sleep(1); } -return &html_page('', $html , ' '); +return &html_page( '', $html, ' ' ); diff --git a/web/bin/uptime.pl b/web/bin/uptime.pl index e8f2bcfb2..bf4882692 100644 --- a/web/bin/uptime.pl +++ b/web/bin/uptime.pl @@ -1,13 +1,13 @@ - # Return the (UNIX) system load for use on menu.shtml # Called from ia5/menu.shtml # Authority: anyone -if ($OS_win or $^O eq 'cygwin') { - return "$Tk_objects{label_uptime_mh}    $Tk_objects{label_uptime_cpu}" +if ( $OS_win or $^O eq 'cygwin' ) { + return + "$Tk_objects{label_uptime_mh}    $Tk_objects{label_uptime_cpu}"; } else { - return `uptime`; + return `uptime`; } diff --git a/web/bin/video_streamer.pl b/web/bin/video_streamer.pl index 051a8801f..4dc29c573 100644 --- a/web/bin/video_streamer.pl +++ b/web/bin/video_streamer.pl @@ -5,11 +5,10 @@ # my $data; -open (F,"-|") or exec "/usr/bin/streamer -q -o /proc/self/fd/1 -f jpeg -j 75"; -while () -{ - $data .= $_; - next; +open( F, "-|" ) or exec "/usr/bin/streamer -q -o /proc/self/fd/1 -f jpeg -j 75"; +while () { + $data .= $_; + next; } -print "Content-Type: image/jpeg\n\n" .$data; +print "Content-Type: image/jpeg\n\n" . $data; diff --git a/web/bin/voicemail.pl b/web/bin/voicemail.pl index 996096234..cd76a1832 100644 --- a/web/bin/voicemail.pl +++ b/web/bin/voicemail.pl @@ -4,9 +4,10 @@ # Authority: anyone -if ('mci' eq lc $config_parms{phone_voicemail_type}) { - my $phone = ($Authorized) ? $config_parms{phone_voicemail_number} : '0001112222'; - my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; +if ( 'mci' eq lc $config_parms{phone_voicemail_type} ) { + my $phone = + ($Authorized) ? $config_parms{phone_voicemail_number} : '0001112222'; + my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; return qq[
    @@ -17,9 +18,9 @@ ]; } -elsif ('asterisk' eq lc $config_parms{phone_voicemail_type}) { +elsif ( 'asterisk' eq lc $config_parms{phone_voicemail_type} ) { my $mailbox = ($Authorized) ? $config_parms{phone_voicemail_number} : '25'; - my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; + my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; return qq[ @@ -30,11 +31,13 @@ name="submit" alt="Voicemail">
    ]; } -elsif ('vocp' eq lc $config_parms{phone_voicemail_type}) { - return qq[Voice Mail]; +elsif ( 'vocp' eq lc $config_parms{phone_voicemail_type} ) { + return + qq[Voice Mail]; } else { - return qq[Voice mail
    ]; + return + qq[Voice mail
    ]; } diff --git a/web/bin/wc_settings.pl b/web/bin/wc_settings.pl index 6fbf194f2..43f4dc97c 100644 --- a/web/bin/wc_settings.pl +++ b/web/bin/wc_settings.pl @@ -17,7 +17,7 @@ # webCamRegisterCam("Driveway", "http://192.168.0.223/usr/yoics0.jpg", 1); # ini parameters wc_address=ip.address,Description -#For HTML out +#For HTML out # # @@ -32,62 +32,64 @@ # # url-to-image output is a fully formatted html page with a fullscreen image(url) # for full html only page image viewing -# +# # if a url-to-image is passed the column formatting is disreguarded and not used # # - - # Get the config parameter for each webcam # We use the wc_address_x from 0 to wc_max - 1 # if we pass anything in output changes to html snippet -my $outmode = @ARGV[0] ; # arg is number of columns to format to -my $arg2 = @ARGV[1]; # if we have a second arg it is the url for full frame -my ($outimage,$rest ) = split / /,$arg2 ; # because we may have extra stuff - -my $html=" \n "; -my $across = 1 ; # how many across are we now ? +my $outmode = @ARGV[0]; # arg is number of columns to format to +my $arg2 = @ARGV[1]; # if we have a second arg it is the url for full frame +my ( $outimage, $rest ) = split / /, $arg2; # because we may have extra stuff -my $wcMax = $config_parms{wc_max}; # max cams - $wcMax = "4" unless $config_parms{wc_max}; # default it +my $html = " \n "; +my $across = 1; # how many across are we now ? -my $wcx="" unless $config_parms{wc_address_1}; - -my $wc_bg_color = $config_parms{wc_bg_color}; - $wc_bg_color = '0x333366' unless $config_parms{wc_bg_color}; +my $wcMax = $config_parms{wc_max}; # max cams +$wcMax = "4" unless $config_parms{wc_max}; # default it +my $wcx = "" unless $config_parms{wc_address_1}; -my $scriptlet=" @@ -65,4 +65,3 @@ return $html; - diff --git a/web/bin/webcam_shows.pl b/web/bin/webcam_shows.pl index 3d7781242..aab25a01c 100644 --- a/web/bin/webcam_shows.pl +++ b/web/bin/webcam_shows.pl @@ -5,92 +5,110 @@ # Dynamic Webcam slideshow (movie) maker for webcam sub-dirs # # V0.00 Pete Flaherty Initial concept release - + #default the camera dir in case we don't have one my $camdir = $config_parms{wc_slide_dir}; - $camdir = "/cameras/cams" unless $config_parms{wc_slide_dir}; +$camdir = "/cameras/cams" unless $config_parms{wc_slide_dir}; -my $wcMax = $config_parms{wc_max}; # max cams - $wcMax = "4" unless $config_parms{wc_max}; # default it +my $wcMax = $config_parms{wc_max}; # max cams +$wcMax = "4" unless $config_parms{wc_max}; # default it -my $wcx="" unless $config_parms{wc_address_1}; # 1 ? +my $wcx = "" unless $config_parms{wc_address_1}; # 1 ? - # Get the list of directories in the camera directory -my $abs_dir = $config_parms{html_dir} . "/" . $config_parms{wc_slide_dir} . "/cams"; -opendir(DIR, $abs_dir ); - my @files = grep{ !/\.$/ && -d "$abs_dir/$_"} readdir(DIR); #readdir(DIR); +my $abs_dir = + $config_parms{html_dir} . "/" . $config_parms{wc_slide_dir} . "/cams"; +opendir( DIR, $abs_dir ); +my @files = grep { !/\.$/ && -d "$abs_dir/$_" } readdir(DIR); #readdir(DIR); closedir(DIR); - -# Sort em for neatness + +# Sort em for neatness @files = sort(@files); - - - - - my $bgcolor = "#333366"; - - my $webdir = $config_parms{wc_slide_dir} . $config_parms{wc_slide_dir} . "/cams/"; - my $html ="\n"; - $html.="\n"; - # make the links to the movie files ... - - my $wcx=1; - foreach $file (@files) { - - my $cam_dir = $abs_dir . "/" . $file ; - opendir(DIR, $cam_dir ); - my @files = grep(/\.jpg$/,readdir(DIR)); - # my @files = grep{ !/\.jpg$/ && -f "$cam_dir/$_"} readdir(DIR); #readdir(DIR); - closedir(DIR); - - @files = sort (@files); - - my $num_images = @files ; - - my $wcThis="wc_address_$wcx"; - my $wcData="x" unless $config_parms{$wcThis}; - # check this wc setting for exist - #Add this cameras settings into the string - my $wcURL = $config_parms{$wcThis}; - my ($wcURL,$wcDescr ) = split(/\,/, $wcURL ); - my $currDir = "/bin/webcam_movie.pl?" . $config_parms{wc_slide_dir} . "/cams/" . $file ; - my $href = ""; - - $html .= "\n"; - $html .= ""; - - $html .= ""; - - # my $last_image = $files[$num_images - 1] ; - my ($last_image, $jnk) = split /\-/,$files[$num_images - 1] ; - if ($last_image) { - $jnk = substr($last_image,0,4) . "/" .substr($last_image,4,2) . "/" .substr($last_image,6,2) . " " .substr($last_image,8,2) . ":" . - substr($last_image,10,2) . ":" .substr($last_image,12,2) . " " .substr($last_image,14) ; - - #$last_image = sprintf ('%04s/2%02s%02d%02d%02d%02d%02d',$last_image, $last_image); - } else { $jnk = "None" ; } - $html .= ""; - - $html .= ""; + + $html .= + ""; + $html .= "\n"; + $wcx++; +} +$html .= "
    " . $href . - " - " . $href . - "#" . $wcx . " " . $wcDescr . "
    " . - $num_images . " images
    " . - "    		" . $href . - " Last Image
    " . " " . $jnk . - "    		" . $href . - " + +my $bgcolor = "#333366"; + +my $webdir = + $config_parms{wc_slide_dir} . $config_parms{wc_slide_dir} . "/cams/"; +my $html = + "\n"; +$html .= "\n"; + +# make the links to the movie files ... + +my $wcx = 1; +foreach $file (@files) { + + my $cam_dir = $abs_dir . "/" . $file; + opendir( DIR, $cam_dir ); + my @files = grep( /\.jpg$/, readdir(DIR) ); + + # my @files = grep{ !/\.jpg$/ && -f "$cam_dir/$_"} readdir(DIR); #readdir(DIR); + closedir(DIR); + + @files = sort (@files); + + my $num_images = @files; + + my $wcThis = "wc_address_$wcx"; + my $wcData = "x" unless $config_parms{$wcThis}; + + # check this wc setting for exist + #Add this cameras settings into the string + my $wcURL = $config_parms{$wcThis}; + my ( $wcURL, $wcDescr ) = split( /\,/, $wcURL ); + my $currDir = + "/bin/webcam_movie.pl?" . $config_parms{wc_slide_dir} . "/cams/" . $file; + my $href = ""; + + $html .= "\n"; + $html .= + ""; - $html .= "\n"; - $wcx++ ; + $html .= + ""; + + # my $last_image = $files[$num_images - 1] ; + my ( $last_image, $jnk ) = split /\-/, $files[ $num_images - 1 ]; + if ($last_image) { + $jnk = + substr( $last_image, 0, 4 ) . "/" + . substr( $last_image, 4, 2 ) . "/" + . substr( $last_image, 6, 2 ) . " " + . substr( $last_image, 8, 2 ) . ":" + . substr( $last_image, 10, 2 ) . ":" + . substr( $last_image, 12, 2 ) . " " + . substr( $last_image, 14 ); + + #$last_image = sprintf ('%04s/2%02s%02d%02d%02d%02d%02d',$last_image, $last_image); } - - $html .= "
    " + . $href + . "
    " + . $href . "#" + . $wcx . " " + . $wcDescr . "
    " + . $num_images + . " images
    " + . "
    "; - - return $html ; + else { $jnk = "None"; } + $html .= + "    		" + . $href + . " Last Image
    " . " " + . $jnk + . "    		" + . $href + . " +
    "; +return $html; diff --git a/web/comics/dailystrips/dailystrips-update b/web/comics/dailystrips/dailystrips-update index 089eb43f9..8ea5ad1bb 100644 --- a/web/comics/dailystrips/dailystrips-update +++ b/web/comics/dailystrips/dailystrips-update @@ -11,7 +11,6 @@ # Current Revision: 1.0.0 # - # Set up use strict; no strict qw(refs); @@ -22,17 +21,18 @@ use POSIX qw(strftime); use Getopt::Long; use File::Copy; - # Variables -my (%options, $version, $dailystrips_version); +my ( %options, $version, $dailystrips_version ); -$version = "1.0.0"; +$version = "1.0.0"; $dailystrips_version = "1.0.28"; # Get options -GetOptions(\%options, 'quiet|q','verbose','proxy=s', - 'proxyauth=s','noenvproxy','version|v','help|h', - 'retries=s','updates=s','minage=s') or exit 1; +GetOptions( + \%options, 'quiet|q', 'verbose', 'proxy=s', + 'proxyauth=s', 'noenvproxy', 'version|v', 'help|h', + 'retries=s', 'updates=s', 'minage=s' +) or exit 1; # Process options: # Note: Blocks have been ordered so that we only do as much as absolutely @@ -40,9 +40,8 @@ GetOptions(\%options, 'quiet|q','verbose','proxy=s', # specified) # Help and version override anything else -if ($options{'help'}) { - print -"Usage: $0 [OPTIONS] +if ( $options{'help'} ) { + print "Usage: $0 [OPTIONS] This program will attempt to download updated dailystrips definitions and save the information to ~/.dailystrips-updates.def @@ -63,238 +62,218 @@ Options: Bugs and comments to dailystrips\@amedico.dhs.org\n"; - exit; + exit; } - # Handle options that are needed first -if ($options{'version'}) { - print "dailystrips version $version\n"; - exit; +if ( $options{'version'} ) { + print "dailystrips version $version\n"; + exit; } -if ($options{'retries'} =~ m/\D/) { - die "Error: 'retries' value must be numeric\n"; +if ( $options{'retries'} =~ m/\D/ ) { + die "Error: 'retries' value must be numeric\n"; } -unless ($options{'retries'}) { - $options{'retries'} = 3; +unless ( $options{'retries'} ) { + $options{'retries'} = 3; } - #Set proxy -if ($options{'proxy'}) -{ - $options{'proxy'} =~ /^(http:\/\/)?(.*?):(.+?)\/?$/i; - unless ($2 and $3) { - die "Error: incorrectly formatted proxy server ('http://server:port' expected)\n"; - } - - $options{'proxy'} = "http://$2:$3"; +if ( $options{'proxy'} ) { + $options{'proxy'} =~ /^(http:\/\/)?(.*?):(.+?)\/?$/i; + unless ( $2 and $3 ) { + die + "Error: incorrectly formatted proxy server ('http://server:port' expected)\n"; + } + + $options{'proxy'} = "http://$2:$3"; } -if (!$options{'noenvproxy'} and !$options{'proxy'} and $ENV{'http_proxy'} ) { - $ENV{'http_proxy'} =~ /(http:\/\/)?(.*?):(.+?)\/?$/i; - unless ($2 and $3) { - die "Error: incorrectly formatted proxy server environment variable\n('http://server:port' expected)\n"; - } - - $options{'proxy'} = "http://$2:$3"; -} +if ( !$options{'noenvproxy'} and !$options{'proxy'} and $ENV{'http_proxy'} ) { + $ENV{'http_proxy'} =~ /(http:\/\/)?(.*?):(.+?)\/?$/i; + unless ( $2 and $3 ) { + die + "Error: incorrectly formatted proxy server environment variable\n('http://server:port' expected)\n"; + } -if ($options{'proxyauth'}) { - unless ($options{'proxyauth'} =~ /^.+?:.+?$/) { - die "Error: incorrectly formatted proxy credentials ('user:pass' expected)\n"; - } + $options{'proxy'} = "http://$2:$3"; } +if ( $options{'proxyauth'} ) { + unless ( $options{'proxyauth'} =~ /^.+?:.+?$/ ) { + die + "Error: incorrectly formatted proxy credentials ('user:pass' expected)\n"; + } +} # verbose overrides quiet -if ($options{'verbose'} and $options{'quiet'}) { - undef $options{'quiet'}; +if ( $options{'verbose'} and $options{'quiet'} ) { + undef $options{'quiet'}; } - # minimum age must be non-zero -if ($options{'minage'} =~ m/\D/) { - die "Error: 'minage' value must be numeric\n"; +if ( $options{'minage'} =~ m/\D/ ) { + die "Error: 'minage' value must be numeric\n"; } -if ($options{'minage'} < 0) { - die "Error: 'minage' value must be >= 0\n"; +if ( $options{'minage'} < 0 ) { + die "Error: 'minage' value must be >= 0\n"; } -unless ($options{'minage'}) { - $options{'minage'} = 0; +unless ( $options{'minage'} ) { + $options{'minage'} = 0; } - # 1 retry by default -unless ($options{'retries'}) { - $options{'retries'} = 1; +unless ( $options{'retries'} ) { + $options{'retries'} = 1; } - # default updates path -unless (defined $options{'updates'}) -{ - $options{'updates'} = &get_homedir() . "/.dailystrips-updates.def"; +unless ( defined $options{'updates'} ) { + $options{'updates'} = &get_homedir() . "/.dailystrips-updates.def"; } - # Download new definitions and save -unless ($options{'quiet'}) -{ - print "dailystrips-update $version starting...\n"; +unless ( $options{'quiet'} ) { + print "dailystrips-update $version starting...\n"; } -&get_updated_defs($options{'updates'}); - +&get_updated_defs( $options{'updates'} ); sub http_get { - my ($url, $referer) = @_; - my ($request, $response, $status); - - my $headers = new HTTP::Headers; - $headers->proxy_authorization_basic(split(/:/, $options{'proxyauth'})); - $headers->referer($referer); - - my $ua = LWP::UserAgent->new; - $ua->agent($options{'useragent'}); - $ua->proxy('http', $options{'proxy'}); - - for (1 .. $options{'retries'}) { - # main request - $request = HTTP::Request->new('GET', $url, $headers); - $response = $ua->request($request); - ($status = $response->status_line()) =~ s/^(\d+)/$1:/; - - if ($response->is_error()) { - if ($options{'verbose'}) { - warn "Warning: could not download $url: $status (attempt $_ of $options{'retries'})\n"; - } - } else { - return $response->content; - } - } - - # if we get here, URL retrieval completely failed - warn "Warning: failed to download $url\n"; - return "ERROR: $status"; -} + my ( $url, $referer ) = @_; + my ( $request, $response, $status ); + + my $headers = new HTTP::Headers; + $headers->proxy_authorization_basic( split( /:/, $options{'proxyauth'} ) ); + $headers->referer($referer); -sub get_updated_defs -{ - # set parameters - my $updates_file = shift; - my $updates_rev_url = "http://dailystrips.sourceforge.net/UPDATES/ds-update-" . $dailystrips_version . ".rev"; - my $updates_url = "http://dailystrips.sourceforge.net/UPDATES/ds-update-" . $dailystrips_version; - my $local_revision = 0; - my $remote_revision = 0; - - - # only update if local update file is old enough - if (time() - (stat($updates_file))[9] < $options{'minage'}) - { - if ($options{'verbose'}) - { - print "Existing file is too new, exiting\n"; - } - return; - } - - # check revision of local file - if (open(UPDATES,"<$updates_file")) # or die "Error: cannot read updates file: $!\n"; - { - while() - { - if (/^#REVISION:\s*(\-?\d+)/i) - { - $local_revision = $1; - #print "line in local: $_\n"; - last; - } - } - close(UPDATES); - } - - if ($options{'verbose'}) - { - print "Local revision: $local_revision\n"; - } - - # find current revision - my $updates_rev = &http_get($updates_rev_url); - - if ($updates_rev =~ /^ERROR/) - { - die "Error: failed to download updates\n"; - } - - - # check revision of downloaded file - for(split(/\n/, $updates_rev)) - { - if (/^#REVISION:\s*(\-?\d+)/) - { - $remote_revision = $1; - last; - } + my $ua = LWP::UserAgent->new; + $ua->agent( $options{'useragent'} ); + $ua->proxy( 'http', $options{'proxy'} ); + + for ( 1 .. $options{'retries'} ) { + + # main request + $request = HTTP::Request->new( 'GET', $url, $headers ); + $response = $ua->request($request); + ( $status = $response->status_line() ) =~ s/^(\d+)/$1:/; + + if ( $response->is_error() ) { + if ( $options{'verbose'} ) { + warn + "Warning: could not download $url: $status (attempt $_ of $options{'retries'})\n"; + } + } + else { + return $response->content; } + } - if ($options{'verbose'}) - { - print "Remote revision: $remote_revision\n"; - } - - # if there is a newer file available, download and save it - if ($remote_revision > $local_revision) - { - unless ($options{'quiet'}) - { - print "Downloading updated definitions..."; - } - - # download updates - my $updates = &http_get($updates_url); - - if ($updates =~ /^ERROR/) - { - print "failed\n"; - die "Error: failed to download updates\n"; - } - - - unless ($options{'quiet'}) - { - print "done\n"; - } - - - open(UPDATES,">$updates_file") or die "Error: cannot write updates ($updates_file) file: $!\n"; - print UPDATES $updates; - close(UPDATES); - } - else - { - unless($options{'quiet'}) - { - print "Local file is already latest revision, exiting.\n"; - } - } + # if we get here, URL retrieval completely failed + warn "Warning: failed to download $url\n"; + return "ERROR: $status"; } -sub get_homedir -{ - if ($^O =~ /Win32/ ) - { - my $dir = $ENV{'USERPROFILE'}; - if ($dir eq "") {$dir = $ENV{'WINDIR'};} - $dir =~ s|\\|/|g; - return $dir; +sub get_updated_defs { + + # set parameters + my $updates_file = shift; + my $updates_rev_url = + "http://dailystrips.sourceforge.net/UPDATES/ds-update-" + . $dailystrips_version . ".rev"; + my $updates_url = "http://dailystrips.sourceforge.net/UPDATES/ds-update-" + . $dailystrips_version; + my $local_revision = 0; + my $remote_revision = 0; + + # only update if local update file is old enough + if ( time() - ( stat($updates_file) )[9] < $options{'minage'} ) { + if ( $options{'verbose'} ) { + print "Existing file is too new, exiting\n"; } - else - { - return (getpwuid($>))[7]; + return; + } + + # check revision of local file + if ( + open( UPDATES, "<$updates_file" ) + ) # or die "Error: cannot read updates file: $!\n"; + { + while () { + if (/^#REVISION:\s*(\-?\d+)/i) { + $local_revision = $1; + + #print "line in local: $_\n"; + last; + } } + close(UPDATES); + } + + if ( $options{'verbose'} ) { + print "Local revision: $local_revision\n"; + } + + # find current revision + my $updates_rev = &http_get($updates_rev_url); + + if ( $updates_rev =~ /^ERROR/ ) { + die "Error: failed to download updates\n"; + } + + # check revision of downloaded file + for ( split( /\n/, $updates_rev ) ) { + if (/^#REVISION:\s*(\-?\d+)/) { + $remote_revision = $1; + last; + } + } + + if ( $options{'verbose'} ) { + print "Remote revision: $remote_revision\n"; + } + + # if there is a newer file available, download and save it + if ( $remote_revision > $local_revision ) { + unless ( $options{'quiet'} ) { + print "Downloading updated definitions..."; + } + + # download updates + my $updates = &http_get($updates_url); + + if ( $updates =~ /^ERROR/ ) { + print "failed\n"; + die "Error: failed to download updates\n"; + } + + unless ( $options{'quiet'} ) { + print "done\n"; + } + + open( UPDATES, ">$updates_file" ) + or die "Error: cannot write updates ($updates_file) file: $!\n"; + print UPDATES $updates; + close(UPDATES); + } + else { + unless ( $options{'quiet'} ) { + print "Local file is already latest revision, exiting.\n"; + } + } +} + +sub get_homedir { + if ( $^O =~ /Win32/ ) { + my $dir = $ENV{'USERPROFILE'}; + if ( $dir eq "" ) { $dir = $ENV{'WINDIR'}; } + $dir =~ s|\\|/|g; + return $dir; + } + else { + return ( getpwuid($>) )[7]; + } } diff --git a/web/comics/dailystrips/install.pl b/web/comics/dailystrips/install.pl index 1fe4e421e..996b9b6d4 100644 --- a/web/comics/dailystrips/install.pl +++ b/web/comics/dailystrips/install.pl @@ -11,32 +11,28 @@ # Current Revision: 1.0.5 # - # Set up use strict; - # Misc vars -my (%options, $prog_version); +my ( %options, $prog_version ); $prog_version = "1.0.28"; - # Not for Win32 -if ($^O =~ /Win32/ ) { - die "install.pl is not for use on Win32 systems. Please see INSTALL file.\n"; +if ( $^O =~ /Win32/ ) { + die + "install.pl is not for use on Win32 systems. Please see INSTALL file.\n"; } - # Editable paths -$options{'sharedir'} = "/usr/share/dailystrips"; -$options{'docdir'} = "/usr/share/doc/dailystrips-$prog_version"; +$options{'sharedir'} = "/usr/share/dailystrips"; +$options{'docdir'} = "/usr/share/doc/dailystrips-$prog_version"; $options{'scriptdir'} = "/usr/bin"; - # Help overrides anything else -for (@ARGV) { - if (/^(--help|-h)$/) { - print < @@ -45,4 +44,4 @@ -"; \ No newline at end of file +"; diff --git a/web/ia4/statuspanel.pl b/web/ia4/statuspanel.pl index b3757c126..30bd18adf 100644 --- a/web/ia4/statuspanel.pl +++ b/web/ia4/statuspanel.pl @@ -4,21 +4,19 @@ # # - -my $tr_office_motion = seconds_remaining_now $timer_office_motion; -my $tr_lr_motion= seconds_remaining_now $timer_lr_motion; -my $tr_jack_motion = seconds_remaining_now $timer_jack_motion; -my $tr_ryan_motion = seconds_remaining_now $timer_ryan_motion; +my $tr_office_motion = seconds_remaining_now $timer_office_motion; +my $tr_lr_motion = seconds_remaining_now $timer_lr_motion; +my $tr_jack_motion = seconds_remaining_now $timer_jack_motion; +my $tr_ryan_motion = seconds_remaining_now $timer_ryan_motion; my $tr_kitchen_motion = seconds_remaining_now $timer_kitchen_motion; -my $tr_garage_motion = seconds_remaining_now $timer_garage_motion; +my $tr_garage_motion = seconds_remaining_now $timer_garage_motion; my $tr_outside_motion = seconds_remaining_now $timer_outside_motion; -my $tsl_office = time_diff ($last_motion_office, $Time, 'minute', 'numeric'); -my $tsl_kitchen = time_diff ($last_motion_kitchen, $Time, 'minute', 'numeric'); - -my $office = sprintf("%4d f", $Save{office_temp}); -my $livingroom = sprintf("%4d f", $Save{livingroom_temp}); +my $tsl_office = time_diff( $last_motion_office, $Time, 'minute', 'numeric' ); +my $tsl_kitchen = time_diff( $last_motion_kitchen, $Time, 'minute', 'numeric' ); +my $office = sprintf( "%4d f", $Save{office_temp} ); +my $livingroom = sprintf( "%4d f", $Save{livingroom_temp} ); return "

    diff --git a/web/ia4/web_sub.pl b/web/ia4/web_sub.pl index fa4d60d8b..e5bc2d63c 100644 --- a/web/ia4/web_sub.pl +++ b/web/ia4/web_sub.pl @@ -2,120 +2,138 @@ # Category=Web_Functions sub X10Lamp { - my $o; - my $objState; - my $icon; - my ($arg1,$arg2,$arg3) = @_; - my $onIcon = "/graphics/$arg2.gif"; - my $offIcon = "/graphics/$arg3.gif"; - $o = &get_object_by_name($arg1); - return 'not found' unless $o; - $objState = $o->state; - $icon = "    " . $objState . ""; - if ($objState eq 'on') {$icon = "";} - if ($objState eq 'off') {$icon = "";} - return $icon; + my $o; + my $objState; + my $icon; + my ( $arg1, $arg2, $arg3 ) = @_; + my $onIcon = "/graphics/$arg2.gif"; + my $offIcon = "/graphics/$arg3.gif"; + $o = &get_object_by_name($arg1); + return 'not found' unless $o; + $objState = $o->state; + $icon = + "" + . $objState + . ""; + + if ( $objState eq 'on' ) { + $icon = + ""; + } + if ( $objState eq 'off' ) { + $icon = + ""; + } + return $icon; } +sub webpause { + my $icon; + # $icon = ""; + # $icon .= " "; + $icon .= " "; -sub webpause { - my $icon; -# $icon = ""; -# $icon .= " "; - $icon .= " "; -# $icon .= " "; -# $icon .= " "; -# $icon .= "



    Performing Operation"; - - return $icon; -} + # $icon .= " "; + # $icon .= " "; + # $icon .= "



    Performing Operation"; + return $icon; +} sub housemode { - my $o; - my $objState; - my $icon; - my ($arg1,$arg2,$arg3) = @_; - my $onIcon = "/graphics/$arg2.gif"; - my $offIcon = "/graphics/$arg3.gif"; - $o = &get_object_by_name($arg1); - return 'not found' unless $o; - $objState = $o->state; - $icon = "/graphics/$arg3.gif"; - if ($objState eq 'on') {$icon = "";} - if ($objState eq 'off') {$icon = "";} - return $icon; + my $o; + my $objState; + my $icon; + my ( $arg1, $arg2, $arg3 ) = @_; + my $onIcon = "/graphics/$arg2.gif"; + my $offIcon = "/graphics/$arg3.gif"; + $o = &get_object_by_name($arg1); + return 'not found' unless $o; + $objState = $o->state; + $icon = "/graphics/$arg3.gif"; + + if ( $objState eq 'on' ) { + $icon = + ""; + } + if ( $objState eq 'off' ) { + $icon = + ""; + } + return $icon; } +sub housemodepause { + my $icon; + # $icon = ""; + # $icon .= " "; + $icon .= " "; -sub housemodepause { - my $icon; -# $icon = ""; -# $icon .= " "; - $icon .= " "; -# $icon .= " "; -# $icon .= " "; -# $icon .= "



    Performing Operation"; - - return $icon; -} + # $icon .= " "; + # $icon .= " "; + # $icon .= "



    Performing Operation"; + return $icon; +} sub web_phonelog { -# Declare Variables + # Declare Variables -use vars qw($PhoneName $PhoneNumber $PhoneTime $PhoneDate); + use vars qw($PhoneName $PhoneNumber $PhoneTime $PhoneDate); -my ($PhoneModemString, $NameDone, $NumberDone, $i, $j); -my (@rejloglines, $NumofCalls); -my (@callloglines, $CallLogTempLine); -my ($PhoneDateLog, $PhoneTimeLog, $PhoneNameLog, $PhoneNumberLog); -my $log_out; -my $customname; + my ( $PhoneModemString, $NameDone, $NumberDone, $i, $j ); + my ( @rejloglines, $NumofCalls ); + my ( @callloglines, $CallLogTempLine ); + my ( $PhoneDateLog, $PhoneTimeLog, $PhoneNameLog, $PhoneNumberLog ); + my $log_out; + my $customname; -$customname = "0"; -$log_out = ""; - open(CALLLOG, "$config_parms{code_dir}/calllog.log"); # Open for input - @callloglines = ; # Open array and - # read in data - close CALLLOG; # Close the file + $customname = "0"; + $log_out = ""; + open( CALLLOG, "$config_parms{code_dir}/calllog.log" ); # Open for input + @callloglines = ; # Open array and + # read in data + close CALLLOG; # Close the file print_log "Announced Recent Callers."; $NumofCalls = 0; - $log_out = ""; + $log_out = + "
    "; foreach $CallLogTempLine (@callloglines) { $NumofCalls = $NumofCalls + 1; - ($PhoneDateLog, $PhoneTimeLog, $PhoneNameLog, $PhoneNumberLog) = (split('`', $CallLogTempLine))[0, 1, 2, 3]; - $log_out .= ""; + ( $PhoneDateLog, $PhoneTimeLog, $PhoneNameLog, $PhoneNumberLog ) = + ( split( '`', $CallLogTempLine ) )[ 0, 1, 2, 3 ]; + $log_out .= + ""; $log_out .= ""; } - $log_out .= "
    $PhoneDateLog $PhoneTimeLog $PhoneNameLog $PhoneNumberLog$PhoneDateLog $PhoneTimeLog $PhoneNameLog $PhoneNumberLog
    "; - $log_out .= ""; + $log_out .= ""; + $log_out .= ""; - $log_out .= ""; - $log_out .= ""; - $log_out .= ""; - $log_out .= "
    NUMBER OF CALLS: $NumofCalls
    "; + $log_out .= ""; + $log_out .= + ""; + $log_out .= + ""; + $log_out .= "
    NUMBER OF CALLS: $NumofCalls
    "; - $log_out .= ""; - return $log_out; + $log_out .= ""; + return $log_out; } - - sub web_clearphonelog { -my $log_out; + my $log_out; -$log_out = ""; + $log_out = ""; - open(CALLLOG, ">$config_parms{code_dir}/calllog.log"); # CLEAR Log + open( CALLLOG, ">$config_parms{code_dir}/calllog.log" ); # CLEAR Log close CALLLOG; - return $log_out; + return $log_out; } diff --git a/web/ia5/modes/house_mode.pl b/web/ia5/modes/house_mode.pl index ab203a661..85fa0e14d 100644 --- a/web/ia5/modes/house_mode.pl +++ b/web/ia5/modes/house_mode.pl @@ -5,4 +5,5 @@ # Authority: anyone -return "Mode $Save{mode}"; +return + "Mode $Save{mode}"; diff --git a/web/ia5/phone/voicemail.pl b/web/ia5/phone/voicemail.pl index 47c766634..9188db484 100644 --- a/web/ia5/phone/voicemail.pl +++ b/web/ia5/phone/voicemail.pl @@ -4,9 +4,10 @@ # Authority: anyone -if ('mci' eq lc $config_parms{phone_voicemail_type}) { - my $phone = ($Authorized) ? $config_parms{phone_voicemail_number} : '0001112222'; - my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; +if ( 'mci' eq lc $config_parms{phone_voicemail_type} ) { + my $phone = + ($Authorized) ? $config_parms{phone_voicemail_number} : '0001112222'; + my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; return qq[
    @@ -17,9 +18,9 @@ ]; } -elsif ('asterisk' eq lc $config_parms{phone_voicemail_type}) { +elsif ( 'asterisk' eq lc $config_parms{phone_voicemail_type} ) { my $mailbox = ($Authorized) ? $config_parms{phone_voicemail_number} : '25'; - my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; + my $pin = ($Authorized) ? $config_parms{phone_voicemail_pin} : '9999'; return qq[ @@ -30,11 +31,13 @@ name="submit" alt="Voicemail">
    ]; } -elsif ('vocp' eq lc $config_parms{phone_voicemail_type}) { - return qq[Voice Mail]; +elsif ( 'vocp' eq lc $config_parms{phone_voicemail_type} ) { + return + qq[Voice Mail]; } else { - return qq[Voice mail
    ]; + return + qq[Voice mail
    ]; } diff --git a/web/ia5/pictures/getcomics.pl b/web/ia5/pictures/getcomics.pl index fb3b464e6..78454994b 100644 --- a/web/ia5/pictures/getcomics.pl +++ b/web/ia5/pictures/getcomics.pl @@ -3,7 +3,7 @@ # perl libs (change lib path below). You need to have netpbm installed. Ron Klinkien. BEGIN { - push (@INC, "/mh/lib", "/mh/lib/site"); + push( @INC, "/mh/lib", "/mh/lib/site" ); } use LWP::UserAgent; @@ -15,11 +15,10 @@ BEGIN my $base; my %pages; -$pages{'dilbert'} = - [ - 'http://www.dilbert.com/comics/dilbert/archive/', - 'img.*?src="(/comics/dilbert/archive/images/dilbert\d+.gif)"' - ]; +$pages{'dilbert'} = [ + 'http://www.dilbert.com/comics/dilbert/archive/', + 'img.*?src="(/comics/dilbert/archive/images/dilbert\d+.gif)"' +]; #$pages{'bobbins'} = # [ @@ -47,7 +46,7 @@ BEGIN # ]; # ----------------------------- page layout, such as it is -------------------- -my $compilation =<<"COMP"; +my $compilation = <<"COMP"; @@ -77,318 +76,339 @@ BEGIN my ( $req, $res ); for my $page ( sort keys %pages ) { - if ( $#ARGV != -1 ) { - next unless grep /$page/i, @ARGV; - } - print "$page\n"; - - # Figure out what we're getting! - my $content = ""; - my $contenttype = ""; - my $numrules = $#{$pages{$page}}; - my $n = -1; # gack - my $url; - - RULE: - for my $rule ( @{$pages{$page}} ) { - - # increment rule number - $n++; - - print " rule ", $n + 1, " of ", $numrules + 1, " : $rule\n"; - - if ( !$content ) { - # First rule is always a URL - $url = $rule; - } else { - ( $url ) = $content =~ m/$rule/mi; - if (!defined( $url )) { - print " error extracting $rule\n"; - $content = undef; - last RULE; - } - } - - # Patch in base and stuff - if ( defined $base ) { - $uri = new URI::URL($url); - - # Gack! relative URL! - if ( $uri->path !~ m|^/| ) { - local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; # gack gack - $uri = URI->new($url)->abs( $base ); - } - - if ( !defined( $uri->host )) { - $uri->scheme( $base->scheme ); - $uri->host( $base->host ); - } - - $url = $uri->as_string; - } - - print " fetching $url\n"; - - $cached = 0; - - # if this is the terminal rule, try a HEAD instead of a GET - if ( $n == $numrules ) { - $req = new HTTP::Request - HEAD => $url; - - $res = $ua->request( $req ); - - if ( $res->is_success ) { - my $utime; - - # See if we get a datestamp - $date = $res->headers->header( 'Last-Modified' ); - if ( defined( $date )) { - print " Last Mod: $date\n"; - $utime = str2time( $date ); - } else { - $utime = 0; - } - $contenttype = $res->content_type; - - # And this is what we call a "hack" - $filename = "${page}_$contenttype"; - $filename =~ s|/|.|g; - - if ( -f $filename ) { - (undef, undef, undef, undef, undef, undef, undef, undef, - undef, $mtime, undef, undef, undef ) = stat( $filename ); - if ( $mtime > $utime ) { - $cached = 1; - } else { - $cached = 0; - } - } - } else { - print " head failed, for some reason.\n"; - } - } - - # Screw caching, since it seems not to work. - $cached = 0; - - if ( $cached ) { - print " cached, not fetching\n"; - } else { - $req = new HTTP::Request - GET => $url; - - $res = $ua->request( $req ); - - if ( $res->is_success ) { - $content = $res->content; - $contenttype = $res->content_type; - - # And this is what we call a "hack" - $filename = "${page}_$contenttype"; - $filename =~ s|/|.|g; - - $base = $res->base; - } else { - print " error fetching data\n"; - $page = $res->as_string; - undef $content; - last RULE; - } - } - - next if !defined( $content ); - next if $n < $numrules; - - print " Item $page, content type $contenttype successfully fetched.\n"; - - # Now, filter the page. - if ( defined( $filters{$page})) { - print " filtering it: "; - - print "start..."; - my @filters = reverse @{$filters{$page}}; - - my $filter = pop @filters; - $content =~ s/^.*?$filter//si; - - print "end..."; - $filter = pop @filters; - $content =~ s/$filter.*?$//si; - - if ( $#filters != -1 ) { - print "body..."; - - while ( $#filters != -1 ) { - my $search = pop @filters; - my $replace = pop @filters; - - $content =~ s/$search/$replace/sgie; - } - } - print "done.\n"; - } - - } - - # Don't bother doing more if we couldn't get the page - next unless $content; - - # Fix up URLs - if ( $contenttype =~ /^text\/html/i ) { - print " Repatching URLs to $base\n"; - $doc = ""; - my $parser = HTML::Parser->new( api_version => 3, - start_h => [\&p_start, - "tagname, text, attr"], - default_h => - [ sub { $doc .= shift }, "text"] - ); - $parser->parse( $content ); - $parser->eof; - $content = $doc; - } - - # Save the damn thing - open( PAGE, ">$filename" ); - print PAGE $content; - close( PAGE ); - - # Figure out the link type, and add it. - if ( $contenttype =~ /^image/i ) { - print " Slicing image... [$page/$contenttype]"; - $new = carve_image( $page, $contenttype ); - unlink( $filename ); # don't leave the old image lying around - print "done.\n"; - - # See if it's got a place of its own to go into. - if (!( $compilation =~ - s|()|$new\n|)) { - $compilation =~ s|()|$new\n$1|; - } - } else { - my $srcurl = ""; - $srcurl = " (from $url)
    "; - $srcurl .= " ($date)" if $date; - if (!( $compilation =~ - s|()|$page$srcurl\n| -)) { - $compilation =~ - s|()|$page$srcurl\n$1|; - } - } + if ( $#ARGV != -1 ) { + next unless grep /$page/i, @ARGV; + } + print "$page\n"; + + # Figure out what we're getting! + my $content = ""; + my $contenttype = ""; + my $numrules = $#{ $pages{$page} }; + my $n = -1; # gack + my $url; + + RULE: + for my $rule ( @{ $pages{$page} } ) { + + # increment rule number + $n++; + + print " rule ", $n + 1, " of ", $numrules + 1, " : $rule\n"; + + if ( !$content ) { + + # First rule is always a URL + $url = $rule; + } + else { + ($url) = $content =~ m/$rule/mi; + if ( !defined($url) ) { + print " error extracting $rule\n"; + $content = undef; + last RULE; + } + } + + # Patch in base and stuff + if ( defined $base ) { + $uri = new URI::URL($url); + + # Gack! relative URL! + if ( $uri->path !~ m|^/| ) { + local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; # gack gack + $uri = URI->new($url)->abs($base); + } + + if ( !defined( $uri->host ) ) { + $uri->scheme( $base->scheme ); + $uri->host( $base->host ); + } + + $url = $uri->as_string; + } + + print " fetching $url\n"; + + $cached = 0; + + # if this is the terminal rule, try a HEAD instead of a GET + if ( $n == $numrules ) { + $req = new HTTP::Request HEAD => $url; + + $res = $ua->request($req); + + if ( $res->is_success ) { + my $utime; + + # See if we get a datestamp + $date = $res->headers->header('Last-Modified'); + if ( defined($date) ) { + print " Last Mod: $date\n"; + $utime = str2time($date); + } + else { + $utime = 0; + } + $contenttype = $res->content_type; + + # And this is what we call a "hack" + $filename = "${page}_$contenttype"; + $filename =~ s|/|.|g; + + if ( -f $filename ) { + ( + undef, undef, undef, undef, undef, undef, undef, + undef, undef, $mtime, undef, undef, undef + ) = stat($filename); + if ( $mtime > $utime ) { + $cached = 1; + } + else { + $cached = 0; + } + } + } + else { + print " head failed, for some reason.\n"; + } + } + + # Screw caching, since it seems not to work. + $cached = 0; + + if ($cached) { + print " cached, not fetching\n"; + } + else { + $req = new HTTP::Request GET => $url; + + $res = $ua->request($req); + + if ( $res->is_success ) { + $content = $res->content; + $contenttype = $res->content_type; + + # And this is what we call a "hack" + $filename = "${page}_$contenttype"; + $filename =~ s|/|.|g; + + $base = $res->base; + } + else { + print " error fetching data\n"; + $page = $res->as_string; + undef $content; + last RULE; + } + } + + next if !defined($content); + next if $n < $numrules; + + print + " Item $page, content type $contenttype successfully fetched.\n"; + + # Now, filter the page. + if ( defined( $filters{$page} ) ) { + print " filtering it: "; + + print "start..."; + my @filters = reverse @{ $filters{$page} }; + + my $filter = pop @filters; + $content =~ s/^.*?$filter//si; + + print "end..."; + $filter = pop @filters; + $content =~ s/$filter.*?$//si; + + if ( $#filters != -1 ) { + print "body..."; + + while ( $#filters != -1 ) { + my $search = pop @filters; + my $replace = pop @filters; + + $content =~ s/$search/$replace/sgie; + } + } + print "done.\n"; + } + + } + + # Don't bother doing more if we couldn't get the page + next unless $content; + + # Fix up URLs + if ( $contenttype =~ /^text\/html/i ) { + print " Repatching URLs to $base\n"; + $doc = ""; + my $parser = HTML::Parser->new( + api_version => 3, + start_h => [ \&p_start, "tagname, text, attr" ], + default_h => [ sub { $doc .= shift }, "text" ] + ); + $parser->parse($content); + $parser->eof; + $content = $doc; + } + + # Save the damn thing + open( PAGE, ">$filename" ); + print PAGE $content; + close(PAGE); + + # Figure out the link type, and add it. + if ( $contenttype =~ /^image/i ) { + print " Slicing image... [$page/$contenttype]"; + $new = carve_image( $page, $contenttype ); + unlink($filename); # don't leave the old image lying around + print "done.\n"; + + # See if it's got a place of its own to go into. + if ( !( $compilation =~ s|()|$new\n| ) ) { + $compilation =~ s|()|$new\n$1|; + } + } + else { + my $srcurl = ""; + $srcurl = " (from $url)
    "; + $srcurl .= " ($date)" if $date; + if ( + !( + $compilation =~ + s|()|$page$srcurl\n| + ) + ) + { + $compilation =~ + s|()|$page$srcurl\n$1|; + } + } } open( PAGE, ">main.html" ); print PAGE $compilation; -close( PAGE ); +close(PAGE); # This is ghastly, but noone seems to have a nice image processing # module for Perl that I could use instead. sub carve_image { - my ( $name, $type ) = @_; - my $html = ""; - - my $filename = "${name}_$type"; - $filename =~ s|/|.|g; - - # Make directory FIXME nuke it if it exists - mkdir $name, 0755 unless -d $name; - - # Convert to a pnm - if ( $type eq "png" ) { - `pngtopnm $filename > $name/$filename`; - } else { - `anytopnm $filename > $name/$filename`; - } - - my $tijd = str2time( $date ); - # Get dimensions (use Image::Info for this!) - $pnmfile = `pnmfile $name/$filename`; - ( $wide, $high ) = $pnmfile =~ m/:.*?,\s(\d+)\sby\s(\d+).*?/i; - - return qq( 
    $pnmfile
    \n) - if !defined( $wide ) or !defined( $high ); - - $html = qq(
    \n); - - for ( $y = 0; $y < $high; $y += 140 ) { - if ( $y + 140 > $high ) { - $h = $high - $y; - } else { - $h = 140; - } - - $html.=""; - - for ( $x = 0; $x < $wide; $x += 150 ) { - if ( $x + 150 > $wide ) { - $w = $wide - $x; - } else { - $w = 150; - } - - `pnmcut $x $y $w $h $name/$filename 2>/dev/null | ppmtogif 2>/dev/null > $name/$ {name}_$ {x}_$ {y}.gif`; - $html .= qq(); - } - $html.="\n"; - } - $html .= "
    \n"; - - # Cleanup - unlink( "$name/$filename" ); - - return $html; + my ( $name, $type ) = @_; + my $html = ""; + + my $filename = "${name}_$type"; + $filename =~ s|/|.|g; + + # Make directory FIXME nuke it if it exists + mkdir $name, 0755 unless -d $name; + + # Convert to a pnm + if ( $type eq "png" ) { + `pngtopnm $filename > $name/$filename`; + } + else { + `anytopnm $filename > $name/$filename`; + } + + my $tijd = str2time($date); + + # Get dimensions (use Image::Info for this!) + $pnmfile = `pnmfile $name/$filename`; + ( $wide, $high ) = $pnmfile =~ m/:.*?,\s(\d+)\sby\s(\d+).*?/i; + + return qq( 
    $pnmfile
    \n) + if !defined($wide) + or !defined($high); + + $html = qq(\n); + + for ( $y = 0; $y < $high; $y += 140 ) { + if ( $y + 140 > $high ) { + $h = $high - $y; + } + else { + $h = 140; + } + + $html .= ""; + + for ( $x = 0; $x < $wide; $x += 150 ) { + if ( $x + 150 > $wide ) { + $w = $wide - $x; + } + else { + $w = 150; + } + + `pnmcut $x $y $w $h $name/$filename 2>/dev/null | ppmtogif 2>/dev/null > $name/$ {name}_$ {x}_$ {y}.gif`; + $html .= + qq(); + } + $html .= "\n"; + } + $html .= "
    \n"; + + # Cleanup + unlink("$name/$filename"); + + return $html; } -sub patchurl - { - my $base = shift; - my $url = shift; - - my $uri = new URI $url; - - eval { - if ( !defined( $uri->scheme ) or !$uri->scheme ) { - $uri = new URI $url, ($base->scheme || 'http'); # what the hell? - } - - # Gack! relative URL! - if ( $uri->path !~ m|^/| ) { - local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; # gack gack - $uri = URI->new($url)->abs( $base ); - } - - if ( !defined( $uri->host )) { - $uri->scheme( $base->scheme || 'http' ); - $uri->host( $base->host ); - } - }; - - $uri->scheme( 'http' ) unless $uri->scheme; # thanks, slashdot - - return $url if $@; # bail out if there's an error. - - $uri->as_string; - } - -sub p_start - { - my $tag = $_[1]; - if (( $_[0] eq "a" ) || ( $_[0] eq "img" ) || ( $_[0] eq "link" ) || - ( $_[0] eq "script" ) || ( $_[0] eq "form" ) || ( $_[0] eq "input" )) { - $tag = "<$_[0]"; - for my $a ( keys %{$_[2]} ) { - my $t = $_[2]->{$a}; - if ( $a =~ /^href|src|action$/i ) { - $t = patchurl( $base, $t ); - $tag .= qq( $a="$t" ); - } else { - $tag .= qq( $a="$t" ); - } - } - $tag =~ s/\s+$//; # just in case - $tag .= ">"; - } - $doc .= $tag; - } +sub patchurl { + my $base = shift; + my $url = shift; + + my $uri = new URI $url; + + eval { + if ( !defined( $uri->scheme ) or !$uri->scheme ) { + $uri = new URI $url, ( $base->scheme || 'http' ); # what the hell? + } + + # Gack! relative URL! + if ( $uri->path !~ m|^/| ) { + local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; # gack gack + $uri = URI->new($url)->abs($base); + } + + if ( !defined( $uri->host ) ) { + $uri->scheme( $base->scheme || 'http' ); + $uri->host( $base->host ); + } + }; + + $uri->scheme('http') unless $uri->scheme; # thanks, slashdot + + return $url if $@; # bail out if there's an error. + + $uri->as_string; +} + +sub p_start { + my $tag = $_[1]; + if ( ( $_[0] eq "a" ) + || ( $_[0] eq "img" ) + || ( $_[0] eq "link" ) + || ( $_[0] eq "script" ) + || ( $_[0] eq "form" ) + || ( $_[0] eq "input" ) ) + { + $tag = "<$_[0]"; + for my $a ( keys %{ $_[2] } ) { + my $t = $_[2]->{$a}; + if ( $a =~ /^href|src|action$/i ) { + $t = patchurl( $base, $t ); + $tag .= qq( $a="$t" ); + } + else { + $tag .= qq( $a="$t" ); + } + } + $tag =~ s/\s+$//; # just in case + $tag .= ">"; + } + $doc .= $tag; +} diff --git a/web/ia6/date.pl b/web/ia6/date.pl index b54ae31a6..7dd47916f 100644 --- a/web/ia6/date.pl +++ b/web/ia6/date.pl @@ -1,8 +1,16 @@ my $html; -my @months = ('January','February','March','April','May','June','July','August','September','October','November','December'); -my @days = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'); -my ($sec,$min,$hour,$day,$month,$year,$day2) = (localtime(time))[0,1,2,3,4,5,6]; +my @months = ( + 'January', 'February', 'March', 'April', 'May', 'June', + 'July', 'August', 'September', 'October', 'November', 'December' +); +my @days = ( + 'Sunday', 'Monday', 'Tuesday', 'Wednesday', + 'Thursday', 'Friday', 'Saturday' +); +my ( $sec, $min, $hour, $day, $month, $year, $day2 ) = + ( localtime(time) )[ 0, 1, 2, 3, 4, 5, 6 ]; + #if ($day < 10) { $day = "0$day"; } $year += "1900"; diff --git a/web/ia6/weatherpoint.pl b/web/ia6/weatherpoint.pl index 6861af9a8..ec4b2fff8 100644 --- a/web/ia6/weatherpoint.pl +++ b/web/ia6/weatherpoint.pl @@ -1,6 +1,6 @@ # Category=Weather # By Douglas J. Nakakihara, doug@dougworld.com -# +# # Requires WeatherURL param in mh.ini set to your particular www.weatherpoint.com page. # Just go there and enter your city or zipcode to get URL. # @@ -9,11 +9,13 @@ my $f_weatherpoint_page = "$config_parms{data_dir}/web/weatherpoint.txt"; my $f_weatherpoint_html = "$config_parms{data_dir}/web/weatherpoint.html"; -$p_weatherpoint_page = new Process_Item("get_url \"$config_parms{weatherpointURL}\" \"$f_weatherpoint_html\""); -$v_get_weatherpoint = new Voice_Cmd('Get weather point'); +$p_weatherpoint_page = new Process_Item( + "get_url \"$config_parms{weatherpointURL}\" \"$f_weatherpoint_html\""); +$v_get_weatherpoint = new Voice_Cmd('Get weather point'); + +if ( $Startup or $Reload ) { # Used for testing -if ($Startup or $Reload) { # Used for testing -#if ((time_cron '17 0,4,5,6,8,12,16,20 * * *' or $state = said $v_get_weatherpoint) and &net_connect_check) { + #if ((time_cron '17 0,4,5,6,8,12,16,20 * * *' or $state = said $v_get_weatherpoint) and &net_connect_check) { print_log "Retrieving weatherpoint weather..."; @@ -21,12 +23,13 @@ start $p_weatherpoint_page; } - -if (done_now $p_weatherpoint_page) { + +if ( done_now $p_weatherpoint_page) { $text = file_read $f_weatherpoint_html; # Find beginning of table and replace table tag - $text =~ s/.+5-Day Forecast.+?width=468>(.+)/$1/s; + $text =~ + s/.+5-Day Forecast.+?width=468>(.+)/
    $1/s; # Find last TH tag and add all needed closing tags $text =~ s/(.+)<\/th>.+/$1<\/th><\/tr><\/table>/s; @@ -40,6 +43,6 @@ # Drop unneeded type faces $text =~ s/face="arial narrow,helvetica"//g; - file_write($f_weatherpoint_page, $text); + file_write( $f_weatherpoint_page, $text ); print $text; } diff --git a/web/misc/mp3Rip.pl b/web/misc/mp3Rip.pl index 5b8490e6f..5480ea0be 100644 --- a/web/misc/mp3Rip.pl +++ b/web/misc/mp3Rip.pl @@ -1,388 +1,498 @@ -my ($function, @parms) = @ARGV; +my ( $function, @parms ) = @ARGV; my $numsteps = 5; -my $bars = 10; -my $perbar = 100/$bars; +my $bars = 10; +my $perbar = 100 / $bars; -if ($function eq 'cddb_list') { - return &get_cdinfo('do_cddb_list'); -} elsif ($function eq 'do_cddb_list') { - return &do_cddb_list(); -} elsif ($function eq 'direct_rip') { - return &get_cdinfo('track_edit'); -} elsif ($function eq 'track_edit') { - return &track_edit(); -} elsif ($function eq 'start_rip') { - return &start_rip(); -} elsif ($function eq 'abort') { - return &abort($parms[0]); -} elsif ($function eq 'delete') { - return &delete($parms[0]); -} elsif ($function eq 'view_log') { - return &view_log($parms[0]); -} elsif ($function eq 'resume_rip') { - return &resume_rip($parms[0]); -} elsif ($function eq 'confirm_files') { - return &confirm_files(); -} else { +if ( $function eq 'cddb_list' ) { + return &get_cdinfo('do_cddb_list'); +} +elsif ( $function eq 'do_cddb_list' ) { + return &do_cddb_list(); +} +elsif ( $function eq 'direct_rip' ) { + return &get_cdinfo('track_edit'); +} +elsif ( $function eq 'track_edit' ) { + return &track_edit(); +} +elsif ( $function eq 'start_rip' ) { + return &start_rip(); +} +elsif ( $function eq 'abort' ) { + return &abort( $parms[0] ); +} +elsif ( $function eq 'delete' ) { + return &delete( $parms[0] ); +} +elsif ( $function eq 'view_log' ) { + return &view_log( $parms[0] ); +} +elsif ( $function eq 'resume_rip' ) { + return &resume_rip( $parms[0] ); +} +elsif ( $function eq 'confirm_files' ) { + return &confirm_files(); +} +else { return &main_page(); } sub abort { - my $cddbid = $_[0]; - my $dir = &mp3Rip_abort($cddbid); - my $html = &html_header("Misterhouse mp3Rip: Aborted Rip $cddbid"); - $html .= "

    The MP3 Rip process has been aborted.\n"; - $html .= "

    The data will be stored as an incomplete process and you can delete it or try to resume.\n"; - if (-d $dir) { - $html .= "

    The directory '$dir' exists and may contain a partially ripped CD. You may want to examine this directory manually to see if any manual actions are necessary.\n"; - } - $html .= "

    Return to the mp3Rip Homepage.\n"; - $html .= "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; - return &html_page("Misterhouse mp3Rip: Aborted Rip $cddbid", $html); + my $cddbid = $_[0]; + my $dir = &mp3Rip_abort($cddbid); + my $html = &html_header("Misterhouse mp3Rip: Aborted Rip $cddbid"); + $html .= "

    The MP3 Rip process has been aborted.\n"; + $html .= + "

    The data will be stored as an incomplete process and you can delete it or try to resume.\n"; + if ( -d $dir ) { + $html .= + "

    The directory '$dir' exists and may contain a partially ripped CD. You may want to examine this directory manually to see if any manual actions are necessary.\n"; + } + $html .= "

    Return to the mp3Rip Homepage.\n"; + $html .= + "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; + return &html_page( "Misterhouse mp3Rip: Aborted Rip $cddbid", $html ); } sub delete { - my $cddbid = $_[0]; - my $dir = &mp3Rip_delete_partial($cddbid); - my $html = &html_header("Misterhouse mp3Rip: Deleted Partial $cddbid"); - $html .= "

    The partial MP3 Rip data has been deleted.\n"; - if (-d $dir) { - $html .= "

    The directory '$dir' exists and may contain a partially ripped CD. You may want to examine this directory manually and delete the MP3s if they are not valid.\n"; - } - $html .= "

    Return to the mp3Rip Homepage.\n"; - $html .= "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; - return &html_page("Misterhouse mp3Rip: Deleted Partial $cddbid", $html); + my $cddbid = $_[0]; + my $dir = &mp3Rip_delete_partial($cddbid); + my $html = &html_header("Misterhouse mp3Rip: Deleted Partial $cddbid"); + $html .= "

    The partial MP3 Rip data has been deleted.\n"; + if ( -d $dir ) { + $html .= + "

    The directory '$dir' exists and may contain a partially ripped CD. You may want to examine this directory manually and delete the MP3s if they are not valid.\n"; + } + $html .= "

    Return to the mp3Rip Homepage.\n"; + $html .= + "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; + return &html_page( "Misterhouse mp3Rip: Deleted Partial $cddbid", $html ); } sub show_percent_bar { - my $percent = $_[0]; - my $html = ''; - $percent =~ s/%$//; - $html .= "

    \n"; - for (my $i = 1; $i <= $bars; $i++) { - if (($percent + ($perbar/2)) >= ($i * $perbar)) { - $html .= "\n"; - } else { - $html .= "\n"; - } - } - $html .= "
      
    \n"; - return $html; + my $percent = $_[0]; + my $html = ''; + $percent =~ s/%$//; + $html .= "\n"; + for ( my $i = 1; $i <= $bars; $i++ ) { + if ( ( $percent + ( $perbar / 2 ) ) >= ( $i * $perbar ) ) { + $html .= "\n"; + } + else { + $html .= "\n"; + } + } + $html .= "
      
    \n"; + return $html; } sub resume_rip { - my $cddbid = $_[0]; - my $ret = &mp3Rip_attempt_reattach_and_restart($cddbid); - unless ($ret) { - &mp3Rip_clean($cddbid); - $ret = &mp3Rip_attempt_reattach_and_restart($cddbid); - } - my $html = &html_header("Misterhouse mp3Rip: Attempting to Resume"); - unless ($ret) { - $html .= "

    ERROR: Could not resume rip! View log to see what is wrong and/or delete the entry and start over. \n"; - $html .= "

    Return to mp3Rip Homepage\n"; - return &html_page("Misterhouse mp3Rip: Failed to Resume", $html); - } - $html .= "

    The MP3 Rip is in progress.

    Since this disc was somehow lost by the system before, you should monitor the progress closely to verify it is completing sucessfully. \n"; - $html .= "

    Return to the mp3Rip Homepage to check the status.\n"; - $html .= "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; - return &html_page("Misterhouse mp3Rip: Rip Resumed", $html); + my $cddbid = $_[0]; + my $ret = &mp3Rip_attempt_reattach_and_restart($cddbid); + unless ($ret) { + &mp3Rip_clean($cddbid); + $ret = &mp3Rip_attempt_reattach_and_restart($cddbid); + } + my $html = &html_header("Misterhouse mp3Rip: Attempting to Resume"); + unless ($ret) { + $html .= + "

    ERROR: Could not resume rip! View log to see what is wrong and/or delete the entry and start over. \n"; + $html .= "

    Return to mp3Rip Homepage\n"; + return &html_page( "Misterhouse mp3Rip: Failed to Resume", $html ); + } + $html .= + "

    The MP3 Rip is in progress.

    Since this disc was somehow lost by the system before, you should monitor the progress closely to verify it is completing sucessfully. \n"; + $html .= + "

    Return to the mp3Rip Homepage to check the status.\n"; + $html .= + "

    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system? Contact Kirk Bauer\n"; + return &html_page( "Misterhouse mp3Rip: Rip Resumed", $html ); } sub view_log { - my $cddbid = $_[0]; - my $html = &html_header("Misterhouse mp3Rip Log Viewer: CDDBID $cddbid"); - $html .= "

    NOTE: Most recent log entry is at the top of the page (i.e. the log entry is displayed in reversed order)\n"; - $html .= "

    Return to mp3Rip Homepage\n"; - if (-f "$config_parms{mp3Rip_work_dir}/$cddbid.log") { - $html = qq| + my $cddbid = $_[0]; + my $html = &html_header("Misterhouse mp3Rip Log Viewer: CDDBID $cddbid"); + $html .= + "

    NOTE: Most recent log entry is at the top of the page (i.e. the log entry is displayed in reversed order)\n"; + $html .= "

    Return to mp3Rip Homepage\n"; + if ( -f "$config_parms{mp3Rip_work_dir}/$cddbid.log" ) { + $html = qq| $html 

     |;
-      foreach (reverse &main::file_read("$config_parms{mp3Rip_work_dir}/$cddbid.log")) {
-         $html .= "$_\n";
-      }
-   } elsif (-f "$config_parms{mp3Rip_archive_dir}/$cddbid.log") {
-      $html .= "
    NOTE: This is an archived log file as the ripping process is complete.
    \n";
-      foreach (reverse &main::file_read("$config_parms{mp3Rip_archive_dir}/$cddbid.log")) {
-         $html .= "$_\n";
-      }
-   }
-   $html .= "
    \n";
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Log Viewer: CDDBID $cddbid", $html);
+        foreach (
+            reverse &main::file_read(
+                "$config_parms{mp3Rip_work_dir}/$cddbid.log") )
+        {
+            $html .= "$_\n";
+        }
+    }
+    elsif ( -f "$config_parms{mp3Rip_archive_dir}/$cddbid.log" ) {
+        $html .=
+          "
    NOTE: This is an archived log file as the ripping process is complete.
    \n";
+        foreach (
+            reverse &main::file_read(
+                "$config_parms{mp3Rip_archive_dir}/$cddbid.log") )
+        {
+            $html .= "$_\n";
+        }
+    }
+    $html .= "
    \n";
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( "Misterhouse mp3Rip Log Viewer: CDDBID $cddbid", $html );
 }
 
 sub get_cdinfo {
-   &mp3Rip_get_cdinfo();
-   my $html = &html_header("Misterhouse mp3Rip Step 1/$numsteps: Retrieving CD Info");
-   $html = qq|
+    &mp3Rip_get_cdinfo();
+    my $html =
+      &html_header("Misterhouse mp3Rip Step 1/$numsteps: Retrieving CD Info");
+    $html = qq|
 
 $html
 
    Retrieving CD information...
 
    Click to continue
 |;
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Step 1/$numsteps: Retrieving CD Info", $html);
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page(
+        "Misterhouse mp3Rip Step 1/$numsteps: Retrieving CD Info", $html );
 }
 
 sub verify_cdinfo {
-   unless (&mp3Rip_is_cdinfo_ready) {
-      my $html = "$_[1]\n";
-      $html .= "
    Still processing... please wait.\n";
-      return $html;
-   }
-   my ($cddbid, $track_numbers, $track_lengths, $total_seconds) = &mp3Rip_parse_cdinfo();
-   unless ($track_numbers) {
-      my $html .= "
    ERROR READING CD INFORMATION!\n";
-      $html .= "
    Things to check:
    \n
      \n";
-      $html .= "   
    •  Is there a CD in the drive?\n";
-      $html .= "   
    •  Try running '$config_parms{mp3Rip_cdinfo}' as the Misterhouse user ('$ENV{USER}') to see if it is working okay. \n";
-      $html .= "
    \n";
-      $html .= "
    Click here when you are ready to try again\n";
-      return $html;
-   }
-   return (undef, $cddbid, $track_numbers, $track_lengths, $total_seconds);
+    unless (&mp3Rip_is_cdinfo_ready) {
+        my $html = "$_[1]\n";
+        $html .= "
    Still processing... please wait.\n";
+        return $html;
+    }
+    my ( $cddbid, $track_numbers, $track_lengths, $total_seconds ) =
+      &mp3Rip_parse_cdinfo();
+    unless ($track_numbers) {
+        my $html .=
+          "
    ERROR READING CD INFORMATION!\n";
+        $html .= "
    Things to check:
    \n
      \n";
+        $html .= "   
    •  Is there a CD in the drive?\n";
+        $html .=
+          "   
    •  Try running '$config_parms{mp3Rip_cdinfo}' as the Misterhouse user ('$ENV{USER}') to see if it is working okay. \n";
+        $html .= "
    \n";
+        $html .=
+          "
    Click here when you are ready to try again\n";
+        return $html;
+    }
+    return ( undef, $cddbid, $track_numbers, $track_lengths, $total_seconds );
 }
 
 sub confirm_files {
-   my %names;
-   my @tracks;
-   foreach (@parms) {
-      my ($name, $value) = split(/=/, $_, 2);
-      $name =~ s/track(\d\D)/track0$1/;
-      if (($value eq 'on') and ($name =~ s/^track(\d+)-rip/$1/)) {
-         push @tracks, $name;
-      } else {
-         $names{$name} = $value;
-      }
-   }
-   my $html = &html_header("Misterhouse mp3Rip Step 4/$numsteps: Filenames");
-   unless (@tracks) {
-      $html .= "
    NO TRACKS SELECTED!\n";
-      $html .= "
    Hit the Back button on your browser and select one or more tracks to rip.\n";
-      return &html_page("Misterhouse mp3Rip Step 4/$numsteps: Filenames", $html);
-   }
-   $html .= "
    IMPORTANT: The following directory should not exist or at least be empty since existing files might be deleted or overwritten!
    \n";
-   my $dir = &mp3Rip_get_dir_name($names{'genre'}, $names{'artist'}, $names{'album'});
-   $html .= "\n";
-   foreach my $track (sort @tracks) {
-      my $trackname = &mp3Rip_get_filename($track, $names{"track${track}artist"}, $names{"track${track}title"}, $names{'album'}, $names{'genre'});
-      $html .= "\n";
-   }
-   $html .= "\n";
-   $html .= "
    Directory
    Track $track
    \n";
-   $html .= "\n";
-   $html .= "\n";
-   $html .= "\n";
-   $html .= "\n";
-   $html .= "\n";
-   $html .= "\n";
-   foreach my $track (@tracks) {
-      $html .= "\n";
-      $html .= "\n";
-      $html .= "\n";
-      $html .= "\n";
-   }
-   $html .= "
    \n";
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Step 4/$numsteps: Filenames", $html);
+    my %names;
+    my @tracks;
+    foreach (@parms) {
+        my ( $name, $value ) = split( /=/, $_, 2 );
+        $name =~ s/track(\d\D)/track0$1/;
+        if ( ( $value eq 'on' ) and ( $name =~ s/^track(\d+)-rip/$1/ ) ) {
+            push @tracks, $name;
+        }
+        else {
+            $names{$name} = $value;
+        }
+    }
+    my $html = &html_header("Misterhouse mp3Rip Step 4/$numsteps: Filenames");
+    unless (@tracks) {
+        $html .=
+          "
    NO TRACKS SELECTED!\n";
+        $html .=
+          "
    Hit the Back button on your browser and select one or more tracks to rip.\n";
+        return &html_page( "Misterhouse mp3Rip Step 4/$numsteps: Filenames",
+            $html );
+    }
+    $html .=
+      "
    IMPORTANT: The following directory should not exist or at least be empty since existing files might be deleted or overwritten!
    \n";
+    my $dir =
+      &mp3Rip_get_dir_name( $names{'genre'}, $names{'artist'},
+        $names{'album'} );
+    $html .=
+        "\n";
+    foreach my $track ( sort @tracks ) {
+        my $trackname = &mp3Rip_get_filename(
+            $track,
+            $names{"track${track}artist"},
+            $names{"track${track}title"},
+            $names{'album'}, $names{'genre'}
+        );
+        $html .=
+          "\n";
+    }
+    $html .=
+      "\n";
+    $html .= "
    Directory
    Track $track
    \n";
+    $html .= "\n";
+    $html .= "\n";
+    $html .= "\n";
+    $html .= "\n";
+    $html .= "\n";
+    $html .= "\n";
+
+    foreach my $track (@tracks) {
+        $html .= "\n";
+        $html .= "\n";
+        $html .= "\n";
+        $html .= "\n";
+    }
+    $html .= "
    \n";
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( "Misterhouse mp3Rip Step 4/$numsteps: Filenames",
+        $html );
 }
 
 sub start_rip {
-   my $error = &mp3Rip_start_rip(@parms);
-   my $html = &html_header("Misterhouse mp3Rip Step 5/$numsteps: Ripping CD");
-   if ($error) {
-      $html .= "
    ERROR: $error!\n";
-      return &html_page("Misterhouse mp3Rip Step 5/$numsteps: Ripping CD", $html);
-   }
-   $html .= "
     The MP3 Rip is in progress.
    Return to the mp3Rip Homepage to check the status.\n";
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Step 5/$numsteps: Ripping CD", $html);
+    my $error = &mp3Rip_start_rip(@parms);
+    my $html  = &html_header("Misterhouse mp3Rip Step 5/$numsteps: Ripping CD");
+    if ($error) {
+        $html .= "
    ERROR: $error!\n";
+        return &html_page( "Misterhouse mp3Rip Step 5/$numsteps: Ripping CD",
+            $html );
+    }
+    $html .=
+      "
     The MP3 Rip is in progress.
    Return to the mp3Rip Homepage to check the status.\n";
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( "Misterhouse mp3Rip Step 5/$numsteps: Ripping CD",
+        $html );
 }
 
-my $default_artist = '';
-my $artist_size = 30;
+my $default_artist  = '';
+my $artist_size     = 30;
 my $max_track_count = 0;
+
 sub do_select_row {
-   my ($special, $label, $name, @list) = @_;
-   my $default = '';
-   my $size = 30;
-   foreach (@list) {
-      $size = length($_) if (length($_) > $size);
-      $_ =~ s/&/&/;
-   }
-   $default = $list[0] if @list;
-   if ($special eq 'artist') {
-      $default_artist = $default;
-      $artist_size = $size;
-   }
-   my $html = "";
-   if ($special eq 'track') {
-      my $shortname = $name;
-      $shortname =~ s/title$//;
-      $html .= "\n";
-      $html .= "$label";
-   } else {
-      $html .= "$label";
-   }
-   $html .= " 0) {
-      $html .= " Other Options: \n";
-      $html .= "\n";
-   }
-   if ($special eq 'track') {
-      my $shortname = $name;
-      $shortname =~ s/title$//;
-      my $id = $label;
-      $id =~ s/^\s*(\d+)\s+.*$/$1/;
-      $html .= "\n";
-      $html .= "\n";
-   }
-   if ($special eq 'artist') {
-      $html .= "(Changes are also applied to tracks below)\n";
-   }
-   $html .= "\n";
-   return $html;
+    my ( $special, $label, $name, @list ) = @_;
+    my $default = '';
+    my $size    = 30;
+    foreach (@list) {
+        $size = length($_) if ( length($_) > $size );
+        $_ =~ s/&/&/;
+    }
+    $default = $list[0] if @list;
+    if ( $special eq 'artist' ) {
+        $default_artist = $default;
+        $artist_size    = $size;
+    }
+    my $html = "";
+    if ( $special eq 'track' ) {
+        my $shortname = $name;
+        $shortname =~ s/title$//;
+        $html .=
+          "\n";
+        $html .= "$label";
+    }
+    else {
+        $html .= "$label";
+    }
+    $html .= " 0 ) {
+        $html .= " Other Options: \n";
+        $html .= "\n";
+    }
+    if ( $special eq 'track' ) {
+        my $shortname = $name;
+        $shortname =~ s/title$//;
+        my $id = $label;
+        $id =~ s/^\s*(\d+)\s+.*$/$1/;
+        $html .=
+          "\n";
+        $html .=
+          "\n";
+    }
+    if ( $special eq 'artist' ) {
+        $html .=
+          "(Changes are also applied to tracks below)\n";
+    }
+    $html .= "\n";
+    return $html;
 }
 
 sub fix_caps {
-   my @ret;
-   foreach (@_) {
-      my $fixed = &mp3Rip_check_caps($_);
-      unless ($fixed eq $_) {
-         push @ret, $fixed;
-      }
-      push @ret, $_;
-   }
-   return (@ret);
+    my @ret;
+    foreach (@_) {
+        my $fixed = &mp3Rip_check_caps($_);
+        unless ( $fixed eq $_ ) {
+            push @ret, $fixed;
+        }
+        push @ret, $_;
+    }
+    return (@ret);
 }
 
 sub remove_dups {
-   for (my $i = 0; $i <= $#_; $i++) {
-      for (my $j = 0; $j <= $#_; $j++) {
-         if ($_[$i] eq $_[$j]) {
-            unless ($i == $j) {
-               splice @_, $i, 1;
-               $i--;
-               last;
+    for ( my $i = 0; $i <= $#_; $i++ ) {
+        for ( my $j = 0; $j <= $#_; $j++ ) {
+            if ( $_[$i] eq $_[$j] ) {
+                unless ( $i == $j ) {
+                    splice @_, $i, 1;
+                    $i--;
+                    last;
+                }
             }
-         }
-      }
-   }
-   return (@_);
+        }
+    }
+    return (@_);
 }
 
 sub track_edit {
-   my %selected;
-   foreach (@parms) {
-      if (s/=on$//) {
-         $selected{$_}++;
-      }
-   }
-   my $html = &html_header("Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming");
-   my ($error, $cddbid, $track_numbers, $track_lengths, $total_seconds) = &verify_cdinfo('track_edit', $html);
-   if ($error) {
-      return &html_page("Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming", $error);
-   }
-   my %combined;
-   my $entrycount = -1;
-   $max_track_count = $#{@$track_numbers} + 1;
-   foreach my $disc (&mp3Rip_get_cddb_discs()) {
-      if ($selected{$disc->[1]}) {
-         my ($genre, $artist, $album, @tracks) = &mp3Rip_get_disc_details($disc);
-         my $trackcount = 0;
-         $entrycount++;
-         $combined{'genre'}->[$entrycount] = $genre;
-         $combined{'artist'}->[$entrycount] = $artist;
-         $combined{'album'}->[$entrycount] = $album;
-         foreach (@tracks) {
-            $trackcount++;
-            $combined{'tracks'}->[$trackcount]->[$entrycount] = $_;
-         }
-      }
-   }
-   $html .= "
    For each row, type in or modify the value in the text box or make a selection from the list, if applicable.\n";
-   $html .= "
    Disc Info\n";
-   $html .= "\n";
-   $html .= "
    \n";
-   $html .= &do_select_row('', 'Genre', 'genre', &remove_dups(@{$combined{'genre'}}), '------------', sort(&mp3Rip_get_id3_genres()));
-   $html .= &do_select_row('artist', 'Artist', 'artist', &remove_dups(&fix_caps(@{$combined{'artist'}})));
-   $html .= &do_select_row('', 'Album', 'album', &remove_dups(&fix_caps(@{$combined{'album'}})));
-   $html .= &do_select_row('', 'Year', 'year');
-   $html .= "
    \n";
-   $html .= "
    Track Info\n";
-   $html .= "\n";
-   $html .= "\n";
-   foreach (my $i = 1; $i <= ($#{@$track_numbers} + 1); $i++) {
-      $html .= &do_select_row('track', "$i ($track_lengths->[$i-1])", "track${i}title", &remove_dups(&fix_caps(@{$combined{'tracks'}->[$i]})));
-   }
-   $html .= "
    Rip?TrackTrack TitleTrack ArtistTrack Comment
    \n";
-   foreach (my $i = 1; $i <= ($#{@$track_numbers} + 1); $i++) {
-      $html .= "[$i-1] . "\">\n";
-   }
-   $html .= "
    \n";
-   $html .= "
    Go back to Step 2\n";
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming", $html);
+    my %selected;
+    foreach (@parms) {
+        if (s/=on$//) {
+            $selected{$_}++;
+        }
+    }
+    my $html =
+      &html_header("Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming");
+    my ( $error, $cddbid, $track_numbers, $track_lengths, $total_seconds ) =
+      &verify_cdinfo( 'track_edit', $html );
+    if ($error) {
+        return &html_page(
+            "Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming", $error );
+    }
+    my %combined;
+    my $entrycount = -1;
+    $max_track_count = $#{@$track_numbers} + 1;
+    foreach my $disc ( &mp3Rip_get_cddb_discs() ) {
+        if ( $selected{ $disc->[1] } ) {
+            my ( $genre, $artist, $album, @tracks ) =
+              &mp3Rip_get_disc_details($disc);
+            my $trackcount = 0;
+            $entrycount++;
+            $combined{'genre'}->[$entrycount]  = $genre;
+            $combined{'artist'}->[$entrycount] = $artist;
+            $combined{'album'}->[$entrycount]  = $album;
+            foreach (@tracks) {
+                $trackcount++;
+                $combined{'tracks'}->[$trackcount]->[$entrycount] = $_;
+            }
+        }
+    }
+    $html .=
+      "
    For each row, type in or modify the value in the text box or make a selection from the list, if applicable.\n";
+    $html .= "
    Disc Info\n";
+    $html .= "\n";
+    $html .=
+      "
    \n";
+    $html .=
+      &do_select_row( '', 'Genre', 'genre',
+        &remove_dups( @{ $combined{'genre'} } ),
+        '------------', sort( &mp3Rip_get_id3_genres() ) );
+    $html .=
+      &do_select_row( 'artist', 'Artist', 'artist',
+        &remove_dups( &fix_caps( @{ $combined{'artist'} } ) ) );
+    $html .=
+      &do_select_row( '', 'Album', 'album',
+        &remove_dups( &fix_caps( @{ $combined{'album'} } ) ) );
+    $html .= &do_select_row( '', 'Year', 'year' );
+    $html .= "
    \n";
+    $html .= "
    Track Info\n";
+    $html .= "\n";
+    $html .=
+      "\n";
+
+    foreach ( my $i = 1; $i <= ( $#{@$track_numbers} + 1 ); $i++ ) {
+        $html .= &do_select_row( 'track', "$i ($track_lengths->[$i-1])",
+            "track${i}title",
+            &remove_dups( &fix_caps( @{ $combined{'tracks'}->[$i] } ) ) );
+    }
+    $html .=
+      "
    Rip?TrackTrack TitleTrack ArtistTrack Comment
    \n";
+    foreach ( my $i = 1; $i <= ( $#{@$track_numbers} + 1 ); $i++ ) {
+        $html .= "[ $i - 1 ] . "\">\n";
+    }
+    $html .= "
    \n";
+    $html .= "
    Go back to Step 2\n";
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( "Misterhouse mp3Rip Step 3/$numsteps: Finalize Naming",
+        $html );
 }
 
 sub do_cddb_list {
-   my $html = &html_header("Misterhouse mp3Rip Step 2/$numsteps: CDDB List");
-   my ($error, $cddbid, $track_numbers, $track_lengths, $total_seconds) = &verify_cdinfo('cddb_list', $html);
-   if ($error) {
-      return &html_page("Misterhouse mp3Rip Step 2/$numsteps: CDDB List", $error);
-   }
-   $html .= "Audio CD Found
      \n";
-   $html .= "
    • Total Length: " . &mp3Rip_format_time($total_seconds) . "\n";
-   $html .= "
    • Number of Tracks: " . ($#{@$track_numbers} + 1) . "\n";
-   $html .= "
    Select at least one CDDB entry to pre-populate your CD info.  If you select more than one you will be presented with a list box for each item on the next page.  You will still be able to make manual changes as well.\n";
-   $html .= "
    If you don't select any discs below, you will have to manually enter information about this CD.\n";
-   $html .= "
    \n";
-   $html .= "\n";
-   foreach my $disc (&mp3Rip_get_cddb_discs()) {
-      my ($genre, $cddbid, $album) = @$disc;
-      $genre = &mp3Rip_convert_genre_to_id3($genre);
-      $album =~ s/&/&/;
-      $html .= "\n";
-   }
-   $html .= "\n";
-   $html .= "
    Select?GenreArtist / AlbumCDDB DiscID
    $genre$album$cddbid
    \n";
-   $html .= "
    TIP: Select all discs that appear to match your CD so you will have a wider variety of choices on the next page.\n";
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page("Misterhouse mp3Rip Step 2/$numsteps: CDDB List", $html);
+    my $html = &html_header("Misterhouse mp3Rip Step 2/$numsteps: CDDB List");
+    my ( $error, $cddbid, $track_numbers, $track_lengths, $total_seconds ) =
+      &verify_cdinfo( 'cddb_list', $html );
+    if ($error) {
+        return &html_page( "Misterhouse mp3Rip Step 2/$numsteps: CDDB List",
+            $error );
+    }
+    $html .= "Audio CD Found
      \n";
+    $html .=
+      "
    • Total Length: " . &mp3Rip_format_time($total_seconds) . "\n";
+    $html .=
+      "
    • Number of Tracks: " . ( $#{@$track_numbers} + 1 ) . "\n";
+    $html .=
+      "
    Select at least one CDDB entry to pre-populate your CD info.  If you select more than one you will be presented with a list box for each item on the next page.  You will still be able to make manual changes as well.\n";
+    $html .=
+      "
    If you don't select any discs below, you will have to manually enter information about this CD.\n";
+    $html .= "
    \n";
+    $html .=
+      "\n";
+
+    foreach my $disc ( &mp3Rip_get_cddb_discs() ) {
+        my ( $genre, $cddbid, $album ) = @$disc;
+        $genre = &mp3Rip_convert_genre_to_id3($genre);
+        $album =~ s/&/&/;
+        $html .=
+          "\n";
+    }
+    $html .=
+      "\n";
+    $html .= "
    Select?GenreArtist / AlbumCDDB DiscID
    $genre$album$cddbid
    \n";
+    $html .=
+      "
    TIP: Select all discs that appear to match your CD so you will have a wider variety of choices on the next page.\n";
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( "Misterhouse mp3Rip Step 2/$numsteps: CDDB List",
+        $html );
 }
 
 sub main_page {
-   my $html = &html_header('Misterhouse mp3Rip Home');
-   $html = "$html\n";
-   if (&mp3Rip_cd_drive_in_use()) {
-      $html .= "
    NOTE: Your CDROM drive is currently in use.  You will not be able to start a new CD until the current ripping process has finished with the drive (but you can start a new CD while others CDs are in the compressing stage).
    \n";
-   } else {
-      $html .= qq|
+    my $html = &html_header('Misterhouse mp3Rip Home');
+    $html = "$html\n";
+    if ( &mp3Rip_cd_drive_in_use() ) {
+        $html .=
+          "
    NOTE: Your CDROM drive is currently in use.  You will not be able to start a new CD until the current ripping process has finished with the drive (but you can start a new CD while others CDs are in the compressing stage).
    \n";
+    }
+    else {
+        $html .= qq|
 Start Ripping a new CD
 
    Insert an audio CD in your CDROM drive and proceed by selecting a link below.
 It is recommended that you use CDDB to automatically retrieve information about
@@ -393,57 +503,76 @@ sub main_page {
 
  • Rip CD manually
 
 |;
-   }
+    }
 
-   my @pending = &mp3Rip_get_pending();
-   if (@pending) {
-      $html .= "\n";
-      $html .= "\n";
-      $html .= "\n";
-      foreach (@pending) {
-         my ($cddbid, $artist, $album, $current, $rip_status, $rip_percent, $compress_status, $compress_percent, $rip_time, $rip_predicted_remaining, $compress_time, $compress_predicted_remaining) = @$_;
-         $html .= "\n";
-         $html .= "\n";
-         $html .= "\n";
-      }
-      $html .= "
    Ripping in Progress
    CDDBIDArtistAlbum TitleCurrent ActivityRip StatusCompress StatusActions
    $cddbid$artist$album$current$rip_status\n";
-         $html .= "
    Elapsed: " . &mp3Rip_format_time($rip_time);
-         $html .= "
    Remaining: " . &mp3Rip_format_time($rip_predicted_remaining);
-         $html .= &show_percent_bar($rip_percent);
-         $html .= "    		$compress_status\n";
-         $html .= "
    Elapsed: " . &mp3Rip_format_time($compress_time);
-         $html .= "
    Remaining: " . &mp3Rip_format_time($compress_predicted_remaining);
-         $html .= &show_percent_bar($compress_percent);
-         $html .= "    		View Log
    Abort
    \n";
-   }
+    my @pending = &mp3Rip_get_pending();
+    if (@pending) {
+        $html .= "\n";
+        $html .=
+          "\n";
+        $html .=
+          "\n";
+        foreach (@pending) {
+            my (
+                $cddbid,          $artist,
+                $album,           $current,
+                $rip_status,      $rip_percent,
+                $compress_status, $compress_percent,
+                $rip_time,        $rip_predicted_remaining,
+                $compress_time,   $compress_predicted_remaining
+            ) = @$_;
+            $html .=
+              "\n";
+            $html .=
+              "\n";
+            $html .=
+              "\n";
+        }
+        $html .= "
    Ripping in Progress
    CDDBIDArtistAlbum TitleCurrent ActivityRip StatusCompress StatusActions
    $cddbid$artist$album$current$rip_status\n";
+            $html .= "
    Elapsed: " . &mp3Rip_format_time($rip_time);
+            $html .= "
    Remaining: "
+              . &mp3Rip_format_time($rip_predicted_remaining);
+            $html .= &show_percent_bar($rip_percent);
+            $html .= "    		$compress_status\n";
+            $html .= "
    Elapsed: " . &mp3Rip_format_time($compress_time);
+            $html .= "
    Remaining: "
+              . &mp3Rip_format_time($compress_predicted_remaining);
+            $html .= &show_percent_bar($compress_percent);
+            $html .= "    		View Log
    Abort
    \n";
+    }
 
-   my @incomplete = &mp3Rip_get_incomplete();
-   if (@incomplete) {
-      $html .= "
    \n";
-      $html .= "\n";
-      $html .= "\n";
-      foreach (@incomplete) {
-         my ($cddbid, $artist, $album, $status) = @$_;
-         $html .= "\n";
-      }
-      $html .= "
    Incomplete CDs
    CDDBIDArtistAlbum TitleStatusActions
    $cddbid$artist$album$status\n";
-         $html .= "View Log \n";
-         $html .= "Resume \n";
-         $html .= "Delete\n";
-         $html .= "
    \n";
-   }
+    my @incomplete = &mp3Rip_get_incomplete();
+    if (@incomplete) {
+        $html .= "
    \n";
+        $html .=
+          "\n";
+        $html .=
+          "\n";
+        foreach (@incomplete) {
+            my ( $cddbid, $artist, $album, $status ) = @$_;
+            $html .=
+              "\n";
+        }
+        $html .= "
    Incomplete CDs
    CDDBIDArtistAlbum TitleStatusActions
    $cddbid$artist$album$status\n";
+            $html .= "View Log \n";
+            $html .= "Resume \n";
+            $html .= "Delete\n";
+            $html .= "
    \n";
+    }
 
-   my @completed = &mp3Rip_get_recently_completed();
-   if (@completed) {
-      $html .= "
    \n";
-      $html .= "\n";
-      foreach (@completed) {
-         $html .= "\n";
-      }
-      $html .= "
    Recently Completed CDs
    $_
    \n";
-   }
+    my @completed = &mp3Rip_get_recently_completed();
+    if (@completed) {
+        $html .= "
    \n";
+        $html .=
+          "\n";
+        foreach (@completed) {
+            $html .= "\n";
+        }
+        $html .= "
    Recently Completed CDs
    $_
    \n";
+    }
 
-   $html .= "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
-   return &html_page('Misterhouse mp3Rip Home', $html);
+    $html .=
+      "
    Questions, bugs, comments, suggestions related to the Misterhouse mp3Rip system?  Contact Kirk Bauer\n";
+    return &html_page( 'Misterhouse mp3Rip Home', $html );
 }
 
diff --git a/web/music/MP3_WebCtrl.pl b/web/music/MP3_WebCtrl.pl
index da2c93bd5..16730cae7 100644
--- a/web/music/MP3_WebCtrl.pl
+++ b/web/music/MP3_WebCtrl.pl
@@ -1,28 +1,28 @@
 
-# this script expect to receive a single function call to control xmms or winamp 
+# this script expect to receive a single function call to control xmms or winamp
 # and an optional argument
 
 my $RC;
-my ( $Cmd, $Arg ) = split ( /=/, $ARGV[0] );
+my ( $Cmd, $Arg ) = split( /=/, $ARGV[0] );
 $Cmd = lc($Cmd);
 
-if ( ! &mp3_running() ) {
-   return &NotRunning;
+if ( !&mp3_running() ) {
+    return &NotRunning;
 }
 
-# the Cmd received will then be pass to mp3 player 
+# the Cmd received will then be pass to mp3 player
 if ( $Cmd ne "status" && $Cmd ne "" ) {
     CMD: {
-    if ( $Cmd eq "play" )     { &mp3_control("Play"); last CMD;}
-    if ( $Cmd eq "stop" )     { &mp3_control("Stop"); last CMD;}
-    if ( $Cmd eq "pause" )    { &mp3_control("pause"); last CMD;}
-    if ( $Cmd eq "volume" )   { &mp3_control("Volume",$Arg); last CMD;}
-    if ( $Cmd eq "volumeup" )   { &mp3_control("VolumeUp"); last CMD;}
-    if ( $Cmd eq "volumedown" )   { &mp3_control("VolumeDown"); last CMD;}
-    if ( $Cmd eq "random" )   { &mp3_control("Random"); last CMD;}
-    if ( $Cmd eq "nextsong" ) { &mp3_control("NextSong");last CMD;}
-    if ( $Cmd eq "prevsong" ) { &mp3_control("PrevSong");last CMD;}
-    if ( $Cmd eq "playlistctrl" ) { return PlaylistCtrl(); last CMD;}
+        if ( $Cmd eq "play" )  { &mp3_control("Play");  last CMD; }
+        if ( $Cmd eq "stop" )  { &mp3_control("Stop");  last CMD; }
+        if ( $Cmd eq "pause" ) { &mp3_control("pause"); last CMD; }
+        if ( $Cmd eq "volume" ) { &mp3_control( "Volume", $Arg ); last CMD; }
+        if ( $Cmd eq "volumeup" )     { &mp3_control("VolumeUp");   last CMD; }
+        if ( $Cmd eq "volumedown" )   { &mp3_control("VolumeDown"); last CMD; }
+        if ( $Cmd eq "random" )       { &mp3_control("Random");     last CMD; }
+        if ( $Cmd eq "nextsong" )     { &mp3_control("NextSong");   last CMD; }
+        if ( $Cmd eq "prevsong" )     { &mp3_control("PrevSong");   last CMD; }
+        if ( $Cmd eq "playlistctrl" ) { return PlaylistCtrl();      last CMD; }
     }
 }
 
@@ -32,7 +32,8 @@
 my $Song = &mp3_get_playlist_title();
 $Song =~ tr/_/ /;    # replace _ by " " to make it clear
 my $Volume = &mp3_get_volume();
-$Volume = ( int( ( $Volume + 2 ) / 5 ) * 5 );    # volume by slice of 5, xmms doesn't change exactly
+$Volume = ( int( ( $Volume + 2 ) / 5 ) * 5 )
+  ;                  # volume by slice of 5, xmms doesn't change exactly
 my $Pos      = &mp3_get_playlist_pos();
 my $SongTime = &mp3_get_output_timestr();
 
@@ -62,7 +63,11 @@ sub mp3_top {
   ";
     my $Value;
 
-    for $Value( 0, 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100 ) {
+    for $Value (
+        0,  5,  10, 15, 20, 25, 30, 35, 40, 45, 50, 55,
+        60, 65, 70, 75, 80, 85, 90, 95, 100
+      )
+    {
         if ( $Volume == $Value ) {
             $HTTP = $HTTP . "
    ";
-           $HTTP = $HTTP . "The mp3 player is not currently running on the system";
-           $HTTP = $HTTP . "
    ";
-           $HTTP = $HTTP . "";
-           return $HTTP;
+    my $HTTP = "";
+    $HTTP = $HTTP . "
    ";
+    $HTTP = $HTTP . "The mp3 player is not currently running on the system";
+    $HTTP = $HTTP . "
    ";
+    $HTTP = $HTTP . "";
+    return $HTTP;
 }
 
-
 # this generate the playlist control frame
-# display refreh the playlist loaded 
+# display refreh the playlist loaded
 # Clear will clear the playlist
 # Shuffle will shuffle the current playlist
 # everything else is a pointer to a directory containing plaulist (m3u)
@@ -118,17 +119,23 @@ sub PlaylistCtrl {
     my $HTTP = Header();
 
     $HTTP = $HTTP . "\n";
-    $HTTP = $HTTP . "\n";
-    $HTTP = $HTTP . "\n";
-    $HTTP = $HTTP . "\n";
-    $HTTP = $HTTP . "\n";
-
-    my ($playlists, %playfiles) = &mp3_playlists;
-    for my $playlist (sort keys %playfiles) {
-        $HTTP = $HTTP . "\n";
+    $HTTP = $HTTP
+      . "\n";
+    $HTTP = $HTTP
+      . "\n";
+    $HTTP = $HTTP
+      . "\n";
+    $HTTP = $HTTP
+      . "\n";
+
+    my ( $playlists, %playfiles ) = &mp3_playlists;
+    for my $playlist ( sort keys %playfiles ) {
+        $HTTP = $HTTP
+          . "\n";
     }
     my $PlaylistLength = &mp3_get_playlist_length();
-    $HTTP = $HTTP . "";
+    $HTTP = $HTTP
+      . "";
     $HTTP = $HTTP . "
     Refresh 
     Clear 
     Shuffle 
     Sort 
     $playlist 
     Refresh 
     Clear 
     Shuffle 
     Sort 
     $playlist 
    		 
    ($PlaylistLength)
    		 
    ($PlaylistLength)
    \n";
     $HTTP = $HTTP . Footer();
 
@@ -138,7 +145,8 @@ sub PlaylistCtrl {
         my $HTTP = "\n";
         $HTTP = $HTTP . "\n";
         $HTTP = $HTTP . "\n";
-        $HTTP = $HTTP . "\n";
+        $HTTP = $HTTP
+          . "\n";
         $HTTP = $HTTP . "\n";
         return $HTTP;
     }
diff --git a/web/music/MP3_WebPlaylist.pl b/web/music/MP3_WebPlaylist.pl
index 0238ab3f5..dbb3bddcf 100644
--- a/web/music/MP3_WebPlaylist.pl
+++ b/web/music/MP3_WebPlaylist.pl
@@ -1,5 +1,5 @@
 
-# this script will display the current mp3 playlist, 
+# this script will display the current mp3 playlist,
 # and will also display the playlist file (m3u).
 # this work with closely with MP3_WebCtrl.pl. All the call
 # to this script are done via the other script.
@@ -8,7 +8,7 @@
 use strict;
 
 my $RC;
-my ( $Cmd, $arg ) = split ( /=/, $ARGV[0] );
+my ( $Cmd, $arg ) = split( /=/, $ARGV[0] );
 $Cmd = ( $Cmd eq "" ) ? "refresh" : $Cmd;
 $Cmd = lc($Cmd);
 
@@ -38,13 +38,14 @@
 # there is a sort done on the dir content, to ease the search
 
 if ( $Cmd eq "list" ) {
-    my ($playlists, %playfiles) = &mp3_playlists;
-    for my $playlist (sort keys %playfiles) {
-            my $DisplayName = $playlist;
-            $DisplayName =~ tr/_/ /;
-            $DisplayName =~ s/-/ - /g;
-            $DisplayName =~ s/.m3u$//;
-            $HTTP = $HTTP . "$DisplayName\n";
+    my ( $playlists, %playfiles ) = &mp3_playlists;
+    for my $playlist ( sort keys %playfiles ) {
+        my $DisplayName = $playlist;
+        $DisplayName =~ tr/_/ /;
+        $DisplayName =~ s/-/ - /g;
+        $DisplayName =~ s/.m3u$//;
+        $HTTP = $HTTP
+          . "$DisplayName\n";
     }
     $HTTP = $HTTP . "\n";
 }
@@ -62,7 +63,8 @@
 sub DisplayPlaylist {
     my $titles = &mp3_get_playlist();
     if ( @$titles == 0 ) {
-        $HTTP = $HTTP . "
    There is no track in the playlist
    \n";
+        $HTTP = $HTTP
+          . "
    There is no track in the playlist
    \n";
     }
     else {
         $HTTP = $HTTP . "\n";
@@ -70,9 +72,11 @@ sub DisplayPlaylist {
 
         foreach my $item (@$titles) {
             my $Time = &mp3_get_playlist_timestr( $pos - 1 );
-            my $Str = "                                                            ";
+            my $Str =
+              "                                                            ";
             $Str = substr( "$pos. $item", 1 );
-            $HTTP = $HTTP . "\n";
+            $HTTP = $HTTP
+              . "\n";
             $pos++;
         }
         $HTTP = $HTTP . "
    $pos. $item .... $Time
    $pos. $item .... $Time
    \n";
@@ -84,7 +88,8 @@ sub Header {
     my $HTTP = "\n";
     $HTTP = $HTTP . "\n";
     $HTTP = $HTTP . "\n";
-    $HTTP = $HTTP . "\n";
+    $HTTP = $HTTP
+      . "\n";
     $HTTP = $HTTP . "\n";
     return $HTTP;
 }
diff --git a/web/music/xmms/MP3_WebXmmsCtrl.pl b/web/music/xmms/MP3_WebXmmsCtrl.pl
index dab5f3d7e..beea793a0 100644
--- a/web/music/xmms/MP3_WebXmmsCtrl.pl
+++ b/web/music/xmms/MP3_WebXmmsCtrl.pl
@@ -6,26 +6,26 @@
 # and an optional argument
 
 my $RC;
-my ( $Cmd, $Arg ) = split ( /=/, $ARGV[0] );
+my ( $Cmd, $Arg ) = split( /=/, $ARGV[0] );
 $Cmd = lc($Cmd);
 
-if ( ! &Xmms_Running ) {
-   return &XmmsNotRunning;
+if ( !&Xmms_Running ) {
+    return &XmmsNotRunning;
 }
 
 # the Cmd received will then be pass to xmms
 if ( $Cmd ne "status" && $Cmd ne "" ) {
     CMD: {
-    if ( $Cmd eq "play" )     { Xmms_Control("Play"); last CMD;}
-    if ( $Cmd eq "stop" )     { Xmms_Control("Stop"); last CMD;}
-    if ( $Cmd eq "pause" )    { Xmms_Control("pause"); last CMD;}
-    if ( $Cmd eq "volume" )   { Xmms_Control("Volume",$Arg); last CMD;}
-    if ( $Cmd eq "volumeup" )   { Xmms_Control("VolumeUp"); last CMD;}
-    if ( $Cmd eq "volumedown" )   { Xmms_Control("VolumeDown"); last CMD;}
-    if ( $Cmd eq "random" )   { Xmms_Control("Random"); last CMD;}
-    if ( $Cmd eq "nextsong" ) { Xmms_Control("NextSong");last CMD;}
-    if ( $Cmd eq "prevsong" ) { Xmms_Control("PrevSong");last CMD;}
-    if ( $Cmd eq "playlistctrl" ) { return PlaylistCtrl(); last CMD;}
+        if ( $Cmd eq "play" )  { Xmms_Control("Play");  last CMD; }
+        if ( $Cmd eq "stop" )  { Xmms_Control("Stop");  last CMD; }
+        if ( $Cmd eq "pause" ) { Xmms_Control("pause"); last CMD; }
+        if ( $Cmd eq "volume" ) { Xmms_Control( "Volume", $Arg ); last CMD; }
+        if ( $Cmd eq "volumeup" )     { Xmms_Control("VolumeUp");   last CMD; }
+        if ( $Cmd eq "volumedown" )   { Xmms_Control("VolumeDown"); last CMD; }
+        if ( $Cmd eq "random" )       { Xmms_Control("Random");     last CMD; }
+        if ( $Cmd eq "nextsong" )     { Xmms_Control("NextSong");   last CMD; }
+        if ( $Cmd eq "prevsong" )     { Xmms_Control("PrevSong");   last CMD; }
+        if ( $Cmd eq "playlistctrl" ) { return PlaylistCtrl();      last CMD; }
     }
     Xmms::sleep(0.25);
 }
@@ -36,7 +36,8 @@
 my $Song = Xmms_Control("get_playlist_title");
 $Song =~ tr/_/ /;    # replace _ by " " to make it clear
 my $Volume = Xmms_Control("get_volume");
-$Volume = ( int( ( $Volume + 2 ) / 5 ) * 5 );    # volume by slice of 5, xmms doesn't change exactly
+$Volume = ( int( ( $Volume + 2 ) / 5 ) * 5 )
+  ;                  # volume by slice of 5, xmms doesn't change exactly
 my $Pos      = Xmms_Control("get_playlist_pos");
 my $SongTime = Xmms_Control("get_output_timestr");
 
@@ -66,7 +67,11 @@ sub mp3_top {
   ";
     my $Value;
 
-    for $Value( 0, 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100 ) {
+    for $Value (
+        0,  5,  10, 15, 20, 25, 30, 35, 40, 45, 50, 55,
+        60, 65, 70, 75, 80, 85, 90, 95, 100
+      )
+    {
         if ( $Volume == $Value ) {
             $HTTP = $HTTP . "