#!/usr/bin/perl # # ASCII-WM-relay-server # (c) hack++ 2006 m.ash, stb # # derived from the original code of: http://blinkserv.sourceforge.net/ # Perl version of the Telnet blinkenlight server # (c) 2003 Wolfgang Dautermann # # Idea (and original in C) from Rene Schickbauer use warnings; use strict ; #use diagnostics; # enable diagnostics only in development version use English; # Support variables like "$EFFECTIVE_USER_ID", etc. (IMO more readable than "$<",...) use Term::ANSIScreen qw/:color :cursor :screen/; use IO::Socket; use Getopt::Long; use Pod::Usage; # # Default values - Configure these variables as you like # ####### USER-MODIFIABLE VARIABLES BEGIN HERE ############################# my $PORT = $EFFECTIVE_USER_ID ? 2006 : 2006; #23; # Listen on port 23 if root, 10001 otherwise # be sure to modify ${MOVIEDIR} in the Makefile # (if you want to use "make install"), and $MOVIEDIR in getblms.sh # (if you use getblms.sh) if you modify it here! my $moviedir = "" ; # where to find the movies my $blmext = "asc" ; # extensions of blm files in the movie directory ####### USER-MODIFIABLE VARIABLES END HERE ############################# my $y_offs =1; my $screen= " \n" . " \n" . " \n" . " \n" . " ___________________________ \n" . " | | | \n" . " |___ | ___| \n" . " |_ | | | _| \n" . " .| | |. ,|. .| | |. \n" . " || | | ) ( | ) ( | | || \n" . " '|_| |' `|' `| |_|' \n" . " |___| | |___| \n" . " | | | \n" . " |_____________|_____________| \n" . " \n" . " ASCII-WM 2OO6 - LIVE !! \n" . " =========================== \n" . " \n" . " \n" . " \n" . " \n" . " \n" . " \n" . " \n"; # # Adjust the User/Group if you like... my $runasuser = "nobody" ; # default UserID to use, if started as root my $runasgroup = "nogroup" ; # default GroupID to use, if started as root my $moviefile = "/mnt/ramdisk/current-frame.asc"; #"-"; my $title = ""; my $activeCheckInterval = 500; # Parse command line options my $help ; GetOptions( "port=i" => \$PORT , "movie=s" => \$moviefile , "user=s" => \$runasuser , "group=s" => \$runasgroup , "title=s" => \$title , "moviedir=s" => \$moviedir , "help" => \$help ) ; pod2usage(-exitstatus => 0) if $help ; $SIG{CHLD} = 'IGNORE'; # do not create Zombie-Processes my $server = IO::Socket::INET->new( Proto => 'tcp', LocalPort => $PORT, Listen => SOMAXCONN, Reuse => 1, Blocking => 1); die "can't setup server" unless $server; # Drops privs # if you start the server as user root (which should not be necessary, # (and should not be done), if you do not want to use a privileged (<1024) # Port (eg. Port 23 - telnet). # Attention! If the User $runasuser (either the default value, or the # command-line-option) does not exist, perl will use zero (which will # be the root-id). Stop the program with an error message here (for # security reasons). # (this will also happen, if one supplies --user=root as command-line # option). (the same for $runasgroup). if ($EFFECTIVE_USER_ID==0) { # do this check only if we are running as root, otherwise we can not change UIDs my $uid = (getpwnam($runasuser))[2] or die "I will not run as user root. Either user $runasuser does not exist, or it has UID=0 \n" ; my $gid = (getgrnam($runasgroup))[2] or die "I will not run as group root. Either group $runasgroup does not exist, or it has GID=0 \n"; ($REAL_GROUP_ID,$EFFECTIVE_GROUP_ID) = ($gid,$gid); ($REAL_USER_ID,$EFFECTIVE_USER_ID) = ($uid,$uid); } print "[Server $0 accepting telnet clients at port $PORT]\n"; while (my $client = $server->accept()) { my $pid = fork(); if (defined $pid) { do { close $client; next; } if $pid; # parent # fall through in child # ?? should I get the filelist (next command) before the client-connect? # maybe faster, but then one have to restart the server, if movies # are added or removed. So that happens 'on the fly'... if (!$moviedir eq "") { my @filelist = glob("$moviedir/*.$blmext") ; my $moviefile = $filelist[ rand @filelist ] or die "Attention: $moviedir does not contain any movies! \n Put some movies in this directory, or restart the server with a moviedir which contains movies!" ; # Error if there are no movies in the moviedir! } if (!$title eq "") { $y_offs = 2; } my $now = localtime time; printf "[Connect from %s] [%s]\n", $client->peerhost, $now ; open(FILEWRITE, ">> ascii-relay.log"); printf FILEWRITE "[%s] [%s]\n", $client->peerhost, $now; close FILEWRITE; my ($author,$name,$description,@moviearray) = readblm($moviefile) ; print $client cls(), locate(0,0) ; print $client $screen ; sleep 1; # Show opening screen for 1 second my $active = 1; # is the file active present - that means - is there a game ? open(FILE_AC, "./active") or $active = 0; if (!$active) { print $client cls(), locate(0,0) ; for (my $j = 1; $j < 2; $j++) { my $l = 1 ; my (@frame) = readframe($moviefile); for (@frame) { print $client locate($l++ ,0), $_; } select ( undef, undef, undef, 100 / 1000 ); } close(FILE_AC); print $client "\n stream starts 10min before game\n"; die "no active game\n"; } print $client cls(), locate(0,0) ; while (1) { my $l = 1 ; my (@frame) = readframe($moviefile); for (@frame) { print $client locate($l++ ,0), $_; } select ( undef, undef, undef, 100 / 1000 ); if ($active > $activeCheckInterval) { open(FILE_AC, "./active") or $active = 0; close(FILE_AC); if (!$active) { print $client "\n stream ended\n"; die "no active game\n"; } else { $active = 1; } } $active++; } close $client; exit ; } else { print $client "too many connections :) .. try later\n"; close $client; } } # read a ASCII or blm-File, strip comments and empty lines # return Moviearray sub readblm { my ($filename) = @_ ; # parameters my (@moviearray,$i,$line,$author,$name,$description) ; open(FILE, "< $filename") or die "Can not open file: $filename \n"; $i = 0 ; $author = ""; $name="" ; $description=""; while () { #next if /^$/; # ignore blank lines if ( /^\#/ ){ # parse special comments, ignore others $author = $1 if /^\# author = (.*)/; $name = $1 if /^\# name = (.*)/; $description = $1 if /^\# description = (.*)/; next; } push @moviearray, $_; } return ($author,$name,$description,@moviearray) ; } sub readframe { my ($filename) = @_ ; # parameters my (@frame) = ""; my (@data) = ""; my ($line) = ""; open(FILE, "< $filename") or die "Can not open file: $filename \n"; @frame = ; close(FILE); return (@frame) ; }