#!/usr/bin/perl -w # Copyright © 2001-2013 Jamie Zawinski # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation. No representations are made about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. # # Created: 28-Jul-2001. require 5; use diagnostics; use strict; use Socket; use POSIX; BEGIN { push @INC, "/var/www/dnalounge/utils/"; } use dna_auth; use Menuify; # DNA::Menuify DNA::Menuify->import qw(error); my $progname = $0; $progname =~ s@.*/@@g; my $version = q{ $Revision: 1.118 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; my $verbose = 0; my $log_p = 1; my $remote_addr; my $cgi_dir = "/var/www/dnalounge"; my $template_file = "$cgi_dir/contact/index.html"; my $config_file = "switcher.conf"; my $html_template = '
Camera Control

Delay:
   

Video Switcher
Show More

Channels
1
 2
 3
 4
 5
 6
 7
 8
 9
 10
 11
 12
 13
 14
 15
 16
S
o
u
r
c
e
s		 1 From behind main bar
2 (no camera)
3 Main bar, wide view
4 Down on DJ platform
5 Stage, wide
6 DJ in front of stage
7 (no camera)
8 Pancam 1 (high)
9 Pancam 2 (low)
10 Dance floor from behind
11 (no camera)
12 Lounge dance floor
13 AUX 1
14 AUX 2 (Booth Tripod)
15 AUX 3 (Booth VCR)
16 Front door
tv
14		 tv
16		 tv
18		 tv
20		 tv
22		 tv
24		 tv
26		 tv
28		 tv
30		 tv
32		 tv
34		 tv
36		 tv
38		 tv
40		 tv
42		 web
cast		    


Panning Camera One

01: stage very wide
02: stage center close
03: stage left close
04: stage right close
05: dance floor wide
06: gogo platform north
07: gogo platform south
08: straight down
09: balcony bar
10: dj platform
11: corner booth north
12: corner booth south
13: coat check balcony
14: rear stage riser
15: ...
16: ...
Pan Delay:  

Pancam 1 All Off.

Panning Camera Two

01: stage wide right
02: stage center right
03: in front of stage right
04: dance floor right wide
05: benches south
06: benches north
07: gogo platform north
08: gogo platform south
09: gogo platform south down
10: ...
11: ...
12: ...
13: ...
14: ...
15: ...
16: ...
Pancam 2 All Off.

   

Last update:   %%FILE_DATE%%
"%%COMMENT%%"

'; my @switcher_settings = (); my @pancam1_settings = (); my @pancam2_settings = (); my $switcher_delay = 2; my $pancam_delay = 2; my $comment = undef; my $file_date = undef; sub splice_template() { open (my $in, '<', $template_file) || error ("$template_file: $! " . `pwd`); local $/ = undef; # read entire file my $template = <$in>; close $in; my $title = 'DNA Lounge Camera Control'; my ($head, $body) = ($html_template =~ m@(.*).*(.*)@si); error ("template unparsable") unless $body; my $links = dna_auth::dna_auth_header_links(); $body =~ s@(

.*?
)@$1$links@si || error ("unable to splice user"); $template =~ s@(\s+).*()@$1$head$2@si || error ("unable to splice head"); $template =~ s@(\s+).*()@$1$body$2@si || error ("unable to splice tail"); $template =~ s@().*()@$1$title$2@si || error ("unable to splice title"); $html_template = $template; } # Parse the HTTP POST data, where lines can be of the forms # c01_02=off # 1-16=3-12 # delay=5 # sub process_post_data($) { my ($data) = @_; print STDERR "$progname: reading submit data\n" if ($verbose); my $w = 16; my $h = 16; my $count = 0; foreach my $line (split (/&/, $data)) { print STDERR "$progname: $line\n" if ($verbose > 1); $_ = $line; my ($key, $val) = m/^([^=]+)=(.*)$/; if ($key eq "delay") { error ("delay must be a number: $val") unless ($val =~ m/\d/ && $val =~ m/^\d*(\.\d*)?$/); $switcher_delay = 0 + $val; } elsif ($key eq "pancam_delay") { error ("pancam_delay must be a number: $val") unless ($val =~ m/\d/ && $val =~ m/^\d*(\.\d*)?$/); $pancam_delay = 0 + $val; } elsif ($key =~ m/^c(\d\d?)_(\d\d?)$/) { if ($count == 0) { # if the first setter we see is of the cXX_YY form, zero out the grids, # since we're only going to get ones, not zeros. for (my $i = 0; $i < $w * $h; $i++) { $switcher_settings[$i] = 0; } for (my $i = 0; $i < $w; $i++) { $pancam1_settings[$i] = 0; $pancam2_settings[$i] = 0; } print STDERR "$progname: reset grid\n" if ($verbose > 1); } my ($x, $y) = ($1, $2); if ($val eq 'off') { $val = 0; } elsif ($val eq 'on') { $val = 1; } else { error ("unrecognized value: \"$val\" in \"$key=$val\""); } error ("out of range: $x") if ($x <= 0 || $x > $w); error ("out of range: $y") if ($y <= 0 || $y > $h); $x--; $y--; $switcher_settings[$y * $w + $x] = $val; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, $val) if ($verbose > 2); $count++; } elsif ($key =~ m/^[cr]\d\d?$/s) { # ignore the row/column lines } elsif ($key =~ m/^pc([ab]?)(\d\d?)$/) { my ($which, $x) = ($1, $2); $which = ($which eq 'b' ? 2 : 1); if ($val eq 'off') { $val = 0; } elsif ($val eq 'on') { $val = 1; } else { error ("unrecognized value: \"$val\" in \"$key=$val\""); } error ("out of range: $x") if ($x <= 0 || $x > $w); $x--; if ($which == 1) { $pancam1_settings[$x] = $val; } else { $pancam2_settings[$x] = $val; } print STDERR "$progname: " . sprintf ("pc%c%d = %d\n", ($which == 1 ? 'a' : 'b'), $x, $val) if ($verbose > 2); $count++; } elsif ($key eq 'comment') { $comment = $val; $comment =~ s/\n+$//s; $comment =~ s/\n+/ /gs; } elsif ($key eq 'extras') { } else { parse_setting_line ($line); $count++; } } } sub make_post_string() { my $body = ""; my $w = 16; my $h = 16; # switcher settings for (my $y = 0; $y < $h; $y++) { for (my $x = 0; $x < $w; $x++) { my $k = sprintf ("c%d_%d", $x+1, $y+1); my $v = ($switcher_settings[($y * $w) + $x] ? "on" : "off"); $body .= "$k=$v\n"; } } $body .= "delay=$switcher_delay\n"; # pancam1 settings for (my $x = 0; $x < $w; $x++) { my $k = sprintf ("pca%d", $x+1); my $v = ($pancam1_settings[$x] ? "on" : "off"); $body .= "$k=$v\n"; } # pancam2 settings for (my $x = 0; $x < $w; $x++) { my $k = sprintf ("pcb%d", $x+1); my $v = ($pancam2_settings[$x] ? "on" : "off"); $body .= "$k=$v\n"; } $body .= "pancam delay=$pancam_delay\n"; $body .= "comment=$comment\n" if ($comment); $body =~ s/\n$//s; $body =~ s/\n/&/gs; return $body; } sub compress_bits(@) { my (@bits) = @_; my $desc = ""; my $max = $#bits+1; for (my $i = 0; $i < $max; $i++) { my $checked = $bits[$i]; if ($checked) { my $i2; for ($i2 = $i+1; $i2 <= $max; $i2++) { $checked = $bits[$i2]; if (!$checked) { if ($i == $i2-1) { $desc .= "," . ($i+1); } elsif ($i == $i2-2) { $desc .= "," . ($i+1) . "," . ($i2); } else { $desc .= "," . ($i+1) . "-" . ($i2); } last; } } $i = $i2; } } $desc =~ s/^,//; return $desc; } sub uncompress_bits($) { my ($nums) = @_; my @result = (); foreach my $nn (split (',', $nums)) { $nn =~ s/\s*//g; if ($nn =~ m/^\d+$/) { push @result, 0 + $nn; } elsif ($nn =~ m/^(\d+)-(\d+)$/) { foreach ($1 .. $2) { push @result, $_; } } else { error ("unparsable range: $nn"); } } return @result; } sub make_settings_string() { my $w = 16; my $h = 16; my %results; # # switcher settings # for (my $x = 0; $x < $w; $x++) { my @bits = (); for (my $y = 0; $y < $h; $y++) { $bits[$y] = $switcher_settings[$y * $w + $x]; } my $desc = compress_bits (@bits); next if ($desc eq ''); $_ = $results{$desc}; my @vals = (defined($_) ? @{$_} : ()); push @vals, $x+1; $results{$desc} = \@vals; } my @results2 = (); foreach my $val (keys(%results)) { my @keys = @{$results{$val}}; my @bits = (); foreach (@keys) { $bits[$_ - 1] = 1; } my $keys = compress_bits (@bits); push @results2, "$keys=$val"; } # sort by the first number on the line @results2 = sort { my $aa = $a; $aa =~ s/^(\d+).*$/$1/; my $bb = $b; $bb =~ s/^(\d+).*$/$1/; return $aa <=> $bb; } @results2; # # pancam settings # { my @bits = (); for (my $x = 0; $x < $w; $x++) { $bits[$x] = $pancam1_settings[$x]; } my $desc = compress_bits (@bits); push @results2, "pancam $desc"; @bits = (); for (my $x = 0; $x < $w; $x++) { $bits[$x] = $pancam2_settings[$x]; } $desc = compress_bits (@bits); push @results2, "pancam2 $desc"; } my $r = join ("\n", @results2); $r = "# $comment\n" . $r if defined($comment); return $r; } # Parse a line and store stuff into @switcher_settings. # # 1-16=3-12 (set to exactly 3-12) # 1-16-=3-12 (turn off 3-12) # 1-16+=3-12 (turn on 3-12) # # pancam 1,2,3 (same but for pancam instead of switcher) # sub parse_setting_line($) { my ($line) = @_; if ($line =~ m/\bpancam/) { parse_pancam_line ($line); return; } my $w = 16; my $h = 16; error ("unparsable switcher line: $line") unless ($line =~ m@^\s*([-0-9,]+?)\s*([-+]?)=\s*([-0-9,]+)\s*$@); my ($keys, $mode, $vals) = ($1, $2, $3); $mode = ($mode eq '+' ? 1 : $mode eq '-' ? -1 : 0); my @vals2 = uncompress_bits ($vals); foreach my $key (uncompress_bits ($keys)) { my $x = $key-1; # zero out this column before we fill in the 1s. if ($mode == 0) { print STDERR "$progname: clearing col $x\n" if ($verbose > 2); for (my $y = 0; $y < $h; $y++) { $switcher_settings[$y * $w + $x] = 0; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, 0) if ($verbose > 2); } } foreach my $val (@vals2) { my $y = $val-1; my $val = ($mode == -1 ? 0 : 1); @switcher_settings [$y * $w + $x] = $val; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, $val) if ($verbose > 2); } } } sub parse_pancam_line($) { my ($line) = @_; my $h = 16; if ($line =~ m@^\s*pancam\s+delay\s*=?\s*(\d+)\s*$@) { $pancam_delay = $1; return; } error ("unparsable pancam line: $line") unless ($line =~ m@^\s*pancam(\d*)\s*([-+]?)=?\s*([-0-9,]*)\s*$@); my ($which, $mode, $vals) = ($1, $2, $3); $which = 1 unless $which; $mode = ($mode eq '+' ? 1 : $mode eq '-' ? -1 : 0); my @vals2 = uncompress_bits ($vals); my @settings; if ($which == 1) { @settings = @pancam1_settings; } elsif ($which == 2) { @settings = @pancam2_settings; } else { error ("no pancam number $which"); } # zero out everything before we fill in the 1s. if ($mode == 0) { print STDERR "$progname: clearing pc$which\n" if ($verbose > 2); for (my $y = 0; $y < $h; $y++) { $settings[$y] = 0; print STDERR "$progname: " . sprintf ("pc$which %d = %d\n", $y+1, 0) if ($verbose > 2); } } foreach my $val (@vals2) { my $y = $val-1; my $val = ($mode == -1 ? 0 : 1); $settings[$y] = $val; print STDERR "$progname: " . sprintf ("pc$which %d = %d\n", $y+1, $val) if ($verbose > 2); } if ($which == 1) { @pancam1_settings = @settings; } elsif ($which == 2) { @pancam2_settings = @settings; } else { error ("no pancam number $which"); } } # Parse the contents of the "settings" config file, which includes # lines of the form # # 1-16=3-12 # sleep=5 # sub parse_settings_string($) { my ($str) = @_; my $w = 16; my $h = 16; # zero out the grid. for (my $i = 0; $i < $w * $h; $i++) { $switcher_settings[$i] = 0; } for (my $i = 0; $i < $w; $i++) { $pancam1_settings[$i] = 0; $pancam2_settings[$i] = 0; } foreach my $line (split ("\n", $str)) { if ($line =~ m/^\s*sleep\s*=\s*([\d.]+)\s*$/i) { $switcher_delay = 0 + $1; next; } elsif ($line =~ m/^\s*pancam\s+delay\s*=\s*([\d.]+)\s*$/i) { $pancam_delay = 0 + $1; next; } parse_setting_line ($line); } } sub read_config_file($) { my ($file) = @_; local *IN; open (IN, "<$file") || error ("couldn't read config file $file"); print STDERR "$progname: reading $file\n" if ($verbose); local $/ = undef; # read entire file my $body = ; $file_date = (stat(IN))[9]; close IN; ($comment) = ($body =~ m@^[^\n]*\n# written on [^\n]*\n# ([^\n]+)\n@s); $comment = '???' unless $comment; $comment =~ s/\+/ /g; $file_date = strftime("%a %b %d %r", localtime($file_date)); $body =~ s/\#.*$//gm; $body =~ s/[ \t]+/ /gm; $body =~ s/^\s+//gm; $body =~ s/\s+$//gm; $body =~ s/\n\n+/\n/gs; error ("configuration $file empty?") if ($body =~ m/^\s*$/s); parse_settings_string ($body); } sub write_config_file($) { my ($file) = @_; do_log() if ($log_p); my $desc = make_settings_string(); my $body = ("# switcher config file\n" . "# written on " . localtime(time) . " by $progname $version\n" . "$desc\n" . "sleep=$switcher_delay\n" . "pancam delay=$pancam_delay\n"); local *OUT; open (OUT, ">$file") || error ("couldn't write config file $file (as " . `whoami` . ")"); print OUT $body; close OUT; print STDERR "$progname: wrote $file\n" if ($verbose); } sub http_post($$) { my ($url, $data) = @_; my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4); $path = "" unless $path; my ($them,$port) = split(/:/, $serverstring); $port = 80 unless $port; my $iaddr = inet_aton($them) || error ("host not found: $them"); my $paddr = sockaddr_in($port, $iaddr); my $proto = getprotobyname('tcp'); local *S; socket(S, PF_INET, SOCK_STREAM, $proto) || error ("socket: $!"); connect(S, $paddr) || error ("$serverstring: $!"); select(S); $| = 1; select(STDOUT); print S "POST /$path HTTP/1.0\r\n"; print S "Host: $them\r\n"; print S "Content-Length: " . length($data) . "\r\n"; print S "\r\n"; print S $data; my $http = ; if ($http =~ m@^HTTP/1\.\d+ [23]0\d\s@) { close S; } else { my $err = $http; local $/ = undef; # read entire file $err .= ; error ("$url reported:\n$err"); } print STDERR "$progname: posted $url\n" if ($verbose); } sub do_log() { my $settings = make_settings_string(); foreach my $line (split (/\n/, $settings)) { system ("logger", "-t", $progname, "$remote_addr: $line"); } } sub draw_grid() { my $html = $html_template; my $w = 16; my $h = 16; # switcher settings for (my $y = 0; $y < $h; $y++) { for (my $x = 0; $x < $w; $x++) { my $checked = $switcher_settings[$y * $w + $x]; if ($checked) { my $x1 = $x+1; my $y1 = $y+1; my $re = "(TYPE=CHECKBOX)[^<>]*?( NAME=\"c${x1}_${y1}\")"; if (! ($html =~ s/$re/$1 CHECKED$2/)) { error ("internal error: coudln't find cell $x1 $y1?"); } } } } # switcher full-column checkboxes for (my $x = 0; $x < $w; $x++) { my $checked = 0; for (my $y = 0; $y < $h; $y++) { $checked += ($switcher_settings[$y * $w + $x]) ? 1 : 0; } if ($checked) { my $x1 = $x+1; my $re = "(TYPE=CHECKBOX)[^<>]*?( NAME=\"c${x1}\")"; if (! ($html =~ s/$re/$1 CHECKED$2/)) { error ("internal error: coudln't find col cell $x1?"); } } } # switcher full-row checkboxes for (my $y = 0; $y < $h; $y++) { my $checked = 0; for (my $x = 0; $x < $w; $x++) { $checked += ($switcher_settings[$y * $w + $x]) ? 1 : 0; } if ($checked) { my $y1 = $y+1; my $re = "(TYPE=CHECKBOX)[^<>]*?( NAME=\"r${y1}\")"; if (! ($html =~ s/$re/$1 CHECKED$2/)) { error ("internal error: coudln't find row cell $y1?"); } } } # pancam settings for (my $y = 0; $y < $h; $y++) { my $checked = $pancam1_settings[$y]; if ($checked) { my $y1 = $y+1; my $re = "(TYPE=CHECKBOX)[^<>]*?( NAME=\"pca${y1})"; if (! ($html =~ s/$re/$1 CHECKED$2/)) { error ("internal error: coudln't find pancam cell $y1?"); } } $checked = $pancam2_settings[$y]; if ($checked) { my $y1 = $y+1; my $re = "(TYPE=CHECKBOX)[^<>]*?( NAME=\"pcb${y1})"; if (! ($html =~ s/$re/$1 CHECKED$2/)) { error ("internal error: coudln't find pancam2 cell $y1?"); } } } if (! ($html =~ s/(NAME=\"delay\"[^>]*?\bVALUE=\")[^\">]*/$1$switcher_delay/)) { error ("internal error: coudln't find delay field?"); } if (! ($html =~ s/(NAME=\"pancam_delay\"[^>]*?\bVALUE=\")[^\">]*/$1$pancam_delay/)) { error ("internal error: couldn't find pancam_delay field?"); } $html =~ s/%%REMOTE%%/$remote_addr/g; $html =~ s/%%FILE_DATE%%/$file_date/g; $html =~ s/%%COMMENT%%/$comment/g; print "Content-Type: text/html\n"; print "Content-Length: " . length($html) . "\n"; print "\n"; print $html; print STDERR "$progname: wrote HTML\n" if ($verbose); } # Write a redirect back to this URL, to turn the POST into a GET. # sub write_redirect() { my $url = ($ENV{HTTPS} eq 'on' ? 'https' : 'http') . "://$ENV{HTTP_HOST}$ENV{REQUEST_URI}"; $url =~ s/\#.*$//; $url =~ s/\?.*$//; print "Status: 302\n"; print "Location: $url\n"; print "Content-Type: text/html\n"; print "\n"; print "$url\n"; print STDERR "$progname: redirected to $url\n" if ($verbose); } sub usage() { print STDERR "usage: $progname [--verbose]\n"; exit 1; } sub main() { $|=1; $progname = "switcher.cgi" if ($progname eq "index.cgi"); $remote_addr = ($ENV{REMOTE_ADDR} || "???"); # Only parse argv if we're not running as a CGI. # if (!defined ($ENV{REQUEST_URI})) { $remote_addr = "cmdline"; while ($_ = $ARGV[0]) { shift @ARGV; if ($_ eq "--verbose") { $verbose++; } elsif (m/^-v+$/) { $verbose += length($_)-1; } elsif (m/^-./) { usage; } else { usage; } } } if (defined($ENV{PATH_INFO}) && $ENV{PATH_INFO} ne "") { error ("extraneous crap in URL: $ENV{PATH_INFO}"); } if ($remote_addr =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { my $iaddr = inet_aton($remote_addr); my $name = gethostbyaddr($iaddr, AF_INET); $remote_addr = $name if ($name); } my $logged_in_user = undef; if ($remote_addr =~ m@^cerebrum\.dnalounge\.com$| ^199\.48\.144\.@six) { # cerebrum and traitor: just let 'em in. $logged_in_user = "internal"; } elsif (defined ($ENV{REQUEST_URI})) { $logged_in_user = dna_auth::dna_auth_demand_login(['cameras']); } $remote_addr .= " $logged_in_user" if ($logged_in_user); splice_template(); read_config_file($config_file); $ENV{REQUEST_METHOD} = '' unless defined ($ENV{REQUEST_METHOD}); $ENV{QUERY_STRING} = '' unless defined ($ENV{QUERY_STRING}); if ($ENV{REQUEST_METHOD} eq "POST" || $ENV{QUERY_STRING} ne "") { print STDERR "$progname: submit method: $ENV{REQUEST_METHOD}\n" if ($verbose); my $data = ''; if ($ENV{REQUEST_METHOD} eq "POST") { local $/ = undef; # read entire file $data .= ; } else { $data = $ENV{QUERY_STRING}; } process_post_data ($data); write_config_file($config_file); write_redirect (); } else { draw_grid (); } } main(); exit 0;