#!/usr/bin/perl
=info
install:
cpan JSON JSON::XS
touch list_full list
chmod a+rw list_full list log.log
freebsd:
www/fcgiwrap www/nginx
rc.conf.local:
nginx_enable="YES"
fcgiwrap_enable="YES"
fcgiwrap_user="www"
nginx:
location / {
index index.html;
add_header Access-Control-Allow-Origin *;
}
location /announce {
fastcgi_pass unix:/var/run/fcgiwrap/fcgiwrap.sock;
fastcgi_param SCRIPT_FILENAME $document_root/master.cgi;
include fastcgi_params;
}
apache .htaccess:
AddHandler cgi-script .cgi
DirectoryIndex index.html
Options +ExecCGI +FollowSymLinks
Order allow,deny
Allow from all
Deny from all
Header set Access-Control-Allow-Origin: *
=cut
use strict;
no strict qw(refs);
use warnings "NONFATAL" => "all";
no warnings qw(uninitialized);
use utf8;
use Socket;
BEGIN {
if ($Socket::VERSION ge '2.008') {
eval qq{use Socket qw(getaddrinfo getnameinfo NI_NUMERICHOST NIx_NOSERV)}; # >5.16
} else {
eval qq{use Socket6 qw(getaddrinfo getnameinfo NI_NUMERICHOST NIx_NOSERV)}; # <5.16
}
};
use Time::HiRes qw(time sleep);
use IO::Socket::IP;
use JSON;
use Net::Ping;
#use Data::Dumper;
our $root_path;
($ENV{'SCRIPT_FILENAME'} || $0) =~ m|^(.+)[/\\].+?$|; #v0w
$root_path = $1 . '/' if $1;
$root_path =~ s|\\|/|g;
our %config = (
#debug => 1,
list_full => $root_path . 'list_full',
list_pub => $root_path . 'list',
log => $root_path . 'log.log',
time_purge => 86400 * 30,
time_alive => 650,
source_check => 1,
ping_timeout => 3,
ping => 1,
mineping => 1,
pingable => 1,
trusted => [qw( 176.9.122.10 )], #masterserver self ip - if server on same ip with masterserver doesnt announced
#blacklist => [], # [qw(2.3.4.5 4.5.6.7 8.9.0.1), '1.2.3.4', qr/^10\.20\.30\./, ], # list, or quoted, ips, or regex
);
do($root_path . 'config.pl');
our $ping = Net::Ping->new("udp", $config{ping_timeout});
$ping->hires();
sub get_params_one(@) {
local %_ = %{ref $_[0] eq 'HASH' ? shift : {}};
for (@_) {
tr/+/ /, s/%([a-f\d]{2})/pack 'H*', $1/gei for my ($k, $v) = /^([^=]+=?)=(.+)$/ ? ($1, $2) : (/^([^=]*)=?$/, /^-/);
$_{$k} = $v;
}
wantarray ? %_ : \%_;
}
sub get_params(;$$) { #v7
my ($string, $delim) = @_;
$delim ||= '&';
read(STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'}) if !$string and $ENV{'CONTENT_LENGTH'};
local %_ =
$string
? get_params_one split $delim, $string
: (get_params_one(@ARGV), map { get_params_one split $delim, $_ } split(/;\s*/, $ENV{'HTTP_COOKIE'}), $ENV{'QUERY_STRING'}, $_);
wantarray ? %_ : \%_;
}
sub get_params_utf8(;$$) {
local $_ = &get_params;
utf8::decode $_ for %$_;
wantarray ? %$_ : $_;
}
sub file_rewrite(;$@) {
local $_ = shift;
return unless open my $fh, '>', $_;
print $fh @_;
}
sub printlog(;@) {
#local $_ = shift;
return unless open my $fh, '>>', $config{log};
print $fh (join ' ', @_), "\n";
}
sub file_read ($) {
open my $f, '<', $_[0] or return;
local $/ = undef;
my $ret = <$f>;
close $f;
return \$ret;
}
sub read_json {
my $ret = {};
eval { $ret = JSON->new->utf8->relaxed(1)->decode(${ref $_[0] ? $_[0] : file_read($_[0]) or \''} || '{}'); }; #'mc
printlog "json error [$@] on [", ${ref $_[0] ? $_[0] : \$_[0]}, "]" if $@;
$ret;
}
sub printu (@) {
for (@_) {
print($_), next unless utf8::is_utf8($_);
my $s = $_;
utf8::encode($s);
print($s);
}
}
sub float {
return ($_[0] < 8 and $_[0] - int($_[0]))
? sprintf('%.' . ($_[0] < 1 ? 3 : ($_[0] < 3 ? 2 : 1)) . 'f', $_[0])
: int($_[0]);
}
sub mineping ($$) {
my ($addr, $port) = @_;
printlog "mineping($addr, $port)" if $config{debug};
my $data;
my $time = time;
eval {
my $socket = IO::Socket::IP->new(
'PeerAddr' => $addr,
'PeerPort' => $port,
'Proto' => 'udp',
'Timeout' => $config{ping_timeout},
);
$socket->send("\x4f\x45\x74\x03\x00\x00\x00\x01");
local $SIG{ALRM} = sub { die "alarm time out"; };
alarm $config{ping_timeout};
$socket->recv($data, POSIX::BUFSIZ) or die "recv: $!";
alarm 0;
1; # return value from eval on normalcy
} or return 0;
return 0 unless length $data;
$time = float(time - $time);
printlog "recvd: ", length $data, " [$time]" if $config{debug};
return $time;
}
sub request (;$) {
my ($r) = @_;
$r ||= \%ENV;
my $param = get_params_utf8;
my $after = sub {
if ($param->{json}) {
my $j = {};
eval { $j = JSON->new->decode($param->{json}) || {} };
$param->{$_} = $j->{$_} for keys %$j;
delete $param->{json};
}
if (%$param) {
s/^false$// for values %$param;
$param->{ip} = $r->{REMOTE_ADDR};
$param->{ip} =~ s/^::ffff://;
for (@{$config{blacklist}}) {
-- tsr_rail.lua
-- Point speed restriction rails
-- Simple rail whose only purpose is to place a TSR on the position, as a temporary solution until the timetable system covers everything.
-- This code resembles the code in lines/stoprail.lua
local function updateform(pos)
local meta = minetest.get_meta(pos)
local pe = advtrains.encode_pos(pos)
local npr = advtrains.interlocking.npr_rails[pe] or 2
meta:set_string("infotext", "Point speed restriction: "..npr)
meta:set_string("formspec", "field[npr;Set point speed restriction:;"..npr.."]")
end
local adefunc = function(def, preset, suffix, rotation)
return {
after_place_node=function(pos)
updateform(pos)
end,
after_dig_node=function(pos)
local pe = advtrains.encode_pos(pos)
advtrains.interlocking.npr_rails[pe] = nil
end,
on_receive_fields = function(pos, formname, fields, player)
if fields.npr then
local pe = advtrains.encode_pos(pos)
advtrains.interlocking.npr_rails[pe] = tonumber(fields.npr)
updateform