BBS-Universal
view release on metacpan or search on metacpan
lib/BBS/Universal.pm view on Meta::CPAN
SOH => chr(0x01),
STX => chr(0x02),
EOT => chr(0x04),
ACK => chr(0x06),
NAK => chr(0x15),
CAN => chr(0x18),
C_CHAR => 'C',
SUPPRESS_GO_AHEAD => 3,
LINEMODE => 34,
SE => 240,
NOP => 214,
DATA_MARK => 242,
BREAK => 243,
INTERRUPT_PROCESS => 244,
ABORT_OUTPUT => 245,
ARE_YOU_THERE => 246,
ERASE_CHARACTER => 247,
ERASE_LINE => 248,
GO_AHEAD => 249,
SB => 250,
WILL => 251,
WONT => 252,
DO => 253,
DONT => 254,
IAC => 255,
PI => (4 * atan2(1, 1)),
MENU_CHOICES => ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', '1', '2', '3', '4', '5', '6', '7', '8', '9', '=', '-', '+', '*', '!', '@', '#', '$', '%', '^', '&'],
SPEEDS => { # This depends on the granularity of Time::HiRes
'FULL' => 0,
'300' => 1 / (300 / 8),
'600' => 1 / (600 / 8),
'1200' => 1 / (1200 / 8),
'2400' => 1 / (2400 / 8),
'4800' => 1 / (4800 / 8),
'9600' => 1 / (9600 / 8),
'19200' => 1 / (19200 / 8),
'38400' => 1 / (38400 / 8),
'57600' => 1 / (57600 / 8),
'115200' => 1 / (115200 / 8),
},
};
use open qw(:std :utf8);
# Modules
use Exporter 'import';
use threads (
'yield',
'exit' => 'threads_only',
'stringify',
);
use Debug::Easy;
use DateTime;
use DBI;
use DBD::mysql;
use File::Basename;
use Time::HiRes qw(time sleep);
use Term::ReadKey;
use Term::ANSIScreen qw( :cursor :screen );
use Term::ANSIColor;
use Text::Format;
use Text::SimpleTable;
use List::Util qw(min max);
use IO::Socket qw(AF_INET SOCK_STREAM SHUT_WR SHUT_RDWR SHUT_RD);
use Cache::Memcached::Fast;
use Number::Format 'format_number';
use XML::RSS::LibXML;
use File::Path;
use File::Which;
use Fcntl qw(:DEFAULT :flock);
use IO::Select;
use POSIX qw(:sys_wait_h);
# use Carp::Always;
BEGIN {
our @ISA = qw(Exporter);
our @EXPORT = qw(
TRUE
FALSE
YES
NO
BLOCKING
NONBLOCKING
PASSWORD
ECHO
SILENT
NUMERIC
ANSI
ASCII
ATASCII
PETSCII
SUPPRESS_GO_AHEAD
SE
LINEMODE
NOP
DATA_MARK
BREAK
INTERRUPT_PROCESS
ABORT_OUTPUT
ARE_YOU_THERE
ERASE_CHARACTER
ERASE_LINE
GO_AHEAD
SB
WILL
WONT
DO
DONT
IAC
);
our @EXPORT_OK = qw();
binmode(STDOUT, ":encoding(UTF-8)");
our $ANSI_VERSION = '0.008';
our $ASCII_VERSION = '0.003';
our $ATASCII_VERSION = '0.007';
our $BBS_LIST_VERSION = '0.002';
lib/BBS/Universal.pm view on Meta::CPAN
}
$self->{'debug'}->DEBUG(['End Parse Telnet Escape']);
return (TRUE);
} ## end sub parse_telnet_escape
sub flush_input {
my $self = shift;
my $key;
unless ($self->{'sysop'} || $self->{'local_mode'}) {
my $handle = $self->{'cl_socket'};
ReadMode 'noecho', $handle;
do {
$key = ReadKey(-1, $handle);
} until (!defined($key) || $key eq '');
ReadMode 'restore', $handle;
} else {
ReadMode 'ultra-raw';
do {
$key = ReadKey(-1);
} until (!defined($key) || $key eq '');
ReadMode 'restore';
} ## end else
return (TRUE);
} ## end sub flush_input
sub get_key {
my $self = shift;
my $echo = shift;
my $blocking = shift;
my $key = undef;
my $mode = $self->{'USER'}->{'text_mode'};
my $timeout = $self->{'USER'}->{'timeout'} * 60;
local $/ = "\x{00}";
if ($self->{'sysop'} || $self->{'local_mode'}) {
ReadMode 'ultra-raw';
$key = ($blocking) ? ReadKey($timeout) : ReadKey(-1);
ReadMode 'restore';
threads->yield;
} elsif ($self->is_connected()) {
my $handle = $self->{'cl_socket'};
ReadMode 'ultra-raw', $self->{'cl_socket'};
my $escape;
do {
$escape = FALSE;
$key = ($blocking) ? ReadKey($timeout, $handle) : ReadKey(-1, $handle);
if ($key eq chr(255)) { # IAC sequence
my $command = ReadKey($timeout, $handle);
my $option = ReadKey($timeout, $handle);
$self->parse_telnet_escape(ord($command), ord($option));
$escape = TRUE;
} ## end if ($key eq chr(255))
} until (!$escape || $self->is_connected());
ReadMode 'restore', $self->{'cl_socket'};
threads->yield;
} ## end elsif ($self->is_connected...)
return ($key) if ($key eq chr(13));
if ($key eq chr(127) or $key eq chr(7)) {
if ($mode eq 'ANSI') {
$key = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
} elsif ($mode eq 'ATASCII') {
$key = $self->{'atascii_meta'}->{'BACKSPACE'}->{'out'};
} elsif ($mode eq 'PETSCII') {
$key = $self->{'petscii_meta'}->{'BACKSPACE'}->{'out'};
} else {
$key = $self->{'ascii_meta'}->{'BACKSPACE'}->{'out'};
}
$self->output("$key $key") if ($echo);
} ## end if ($key eq chr(127) or...)
threads->yield;
return ($key);
} ## end sub get_key
sub get_line {
my $self = shift;
my $type = shift;
my $line = shift;
my $echo = $type->{'type'};
my $limit = $type->{'max'};
my $choices = $type->{'choices'} if (exists($type->{'choices'}));
if (exists($type->{'default'})) {
$line = $type->{'default'};
}
$self->{'debug'}->DEBUG(['Start Get Line']);
$self->flush_input();
my $key;
$self->output($line) if ($line ne '');
my $mode = $self->{'USER'}->{'text_mode'};
my $backspace;
if ($mode eq 'ANSI') {
$backspace = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
} elsif ($mode eq 'ATASCII') {
$backspace = $self->{'atascii_meta'}->{'BACKSPACE'}->{'out'};
} elsif ($mode eq 'PETSCII') {
$backspace = $self->{'petscii_meta'}->{'BACKSPACE'}->{'out'};
} else {
$backspace = $self->{'ascii_meta'}->{'BACKSPACE'}->{'out'};
}
if ($echo == PASSWORD) {
$self->{'debug'}->DEBUG([' Mode: PASSWORD']);
while (($self->is_connected() || $self->{'local_mode'}) && $key ne chr(13) && $key ne chr(3)) {
if (length($line) <= $limit) {
$key = $self->get_key(SILENT, BLOCKING);
return ('') if (defined($key) && $key eq chr(3));
if (defined($key) && $key ne '') {
if ($key eq $backspace) {
my $len = length($line);
if ($len > 0) {
$self->output("$key $key");
chop($line);
}
} elsif ($key ne chr(13) && $key ne chr(3) && $key ne chr(10) && ord($key) > 31 && ord($key) < 127) {
$self->output('*');
$line .= $key;
} else {
$self->output('[% RING BELL %]');
}
} ## end if (defined($key) && $key...)
} else {
$key = $self->get_key(SILENT, BLOCKING);
if (defined($key) && $key eq chr(3)) {
return ('');
}
if (defined($key) && ($key eq $backspace)) {
$key = $backspace;
$self->output("$key $key");
chop($line);
} else {
$self->output('[% RING BELL %]');
}
} ## end else [ if (length($line) <= $limit)]
} ## end while (($self->is_connected...))
} elsif ($echo == RADIO) {
$self->{'debug'}->DEBUG([' Mode: RADIO']);
my $mapping;
my @menu_choices = @{$self->{'MENU CHOICES'}};
foreach my $choice (@{$choices}) {
$mapping->{ shift(@menu_choices) } = {
'command' => $choice,
'color' => 'WHITE',
'access_level' => 'USER',
'text' => $choice,
}
}
$self->output("\n\n");
$self->show_choices($mapping);
$self->prompt('Choose');
my $key;
lib/BBS/Universal.pm view on Meta::CPAN
} elsif ($text =~ /^38;5;\d+m/) {
return ('ANSI 8 BIT');
} elsif ($text =~ /^(\d+)m/) {
my $color = $1 + 0;
if (($color >= 30 && $color <= 37) || ($color >= 40 && $color <= 47) || $color == 39 || $color == 49) {
return('ANSI 3 BIT');
} elsif (($color >= 90 && $color <= 97) || ($color >= 100 && $color <= 107)) {
return('ANSI 4 BIT');
}
}
} ## end sub ansi_type
sub ansi_decode {
my ($self, $text) = @_;
# Nothing to do for very short strings
return ($text) unless ((defined $text && length($text) > 1) || $text !~ /\[\%/);
# If a literal screen reset token exists, remove it and run reset once.
if ($text =~ /\[\%\s*SCREEN\s+RESET\s*\%\]/i) {
$text =~ s/\[\%\s*SCREEN\s+RESET\s*\%\]//gis;
system('reset');
}
# Convenience CSI
my $am = $self->{'ansi_meta'}->{'foreground'};
my $csi = $self->{'ansi_meta'}->{'special'}->{'CSI'}->{'out'};
#
# Targeted parameterized tokens (single-pass). These are simple Regex -> CSI conversions.
#
$text =~ s/\[\%\s*LOCATE\s+(\d+)\s*,\s*(\d+)\s*\%\]/ $csi . "$2;$1" . 'H' /eigs;
$text =~ s/\[\%\s*SCROLL\s+UP\s+(\d+)\s*\%\]/ $csi . $1 . 'S' /eigs;
$text =~ s/\[\%\s*SCROLL\s+DOWN\s+(\d+)\s*\%\]/ $csi . $1 . 'T' /eigs;
# HORIZONTAL RULE expands into a sequence of meta-tokens (resolved later).
$text =~ s/\[\%\s*HORIZONTAL\s+RULE\s+(.*?)\s*\%\]/
do {
my $color = defined $1 && $1 ne '' ? uc $1 : 'DEFAULT';
'[% RETURN %][% B_' . $color . ' %][% CLEAR LINE %][% RESET %]';
}/eigs;
# 24-bit RGB underline/foreground/background
$text =~ s/\[\%\s+UNDERLINE\s+COLOR\s+RGB\s+(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s+\%\]/
do { my ($red, $green, $blue) = ($1&255, $2&255, $3&255); "\e[58;2;$red;$green;${blue}m" }/eigs;
$text =~ s/\[\%\s+RGB\s+(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s+\%\]/
do { my ($red, $green, $blue) = ($1&255,$2&255,$3&255); "\e[38;2;$red;$green;${blue}m" }/eigs;
$text =~ s/\[\%\s+B_RGB\s+(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s+\%\]/
do { my ($red, $green, $blue) = ($1&255,$2&255,$3&255); "\e[48;2;$red;$green;${blue}m" }/eigs;
#
# Flatten the ansi_meta lookup to a simple, case-insensitive hash for a single-pass
# substitution of tokens like [% RED %], [% RESET %], etc.
#
if ($text =~ /CLS/i && $self->{'local_mode'}) {
my $ch = locate(($self->{'CACHE'}->get('START_ROW') + $self->{'CACHE'}->get('ROW_ADJUST')), 1) . cldown;
$text =~ s/\[\%\s+CLS\s+\%\]/$ch/gsi;
}
my %lookup;
for my $code (qw(foreground background special clear cursor attributes)) {
my $map = $self->{'ansi_meta'}->{$code} or next;
while (my ($name, $info) = each %{$map}) {
next unless (defined($info->{out}));
$lookup{ lc $name } = $info->{out};
}
} ## end for my $code (qw(foreground background special clear cursor attributes))
# Final single-pass replacement for remaining [% ... %] tokens.
# If token matches a lookup entry, substitute; otherwise if it's a named char use charnames;
# else leave token visible.
###
$text =~ s/\[\%\s*(.+?)\s*\%\]/
do {
my $tok = $1;
my $key = lc $tok;
if ( exists $lookup{$key} ) {
$lookup{$key};
} elsif ( defined( my $char = charnames::string_vianame($tok) ) ) {
$char;
} else {
$&; # leave the original token intact
}
}/egis;
###
return $text;
} ## end sub ansi_decode
sub ansi_output {
my $self = shift;
my $text = shift;
$self->{'debug'}->DEBUG(['Start ANSI Output']);
my $mlines = (exists($self->{'USER'}->{'max_rows'})) ? $self->{'USER'}->{'max_rows'} - 3 : 21;
my $lines = $mlines;
$text = $self->ansi_decode($text);
my $s_len = length($text);
my $nl = $self->{'ansi_meta'}->{'cursor'}->{'NEWLINE'}->{'out'};
foreach my $count (0 .. $s_len) {
my $char = substr($text, $count, 1);
if ($char eq "\n") {
if ($text !~ /$nl/ && !$self->{'local_mode'}) { # translate only if the file doesn't have ASCII newlines
$char = $nl;
}
$lines--;
if ($lines <= 0) {
$lines = $mlines;
last unless ($self->scroll($nl));
next;
}
} ## end if ($char eq "\n")
$self->send_char($char);
} ## end foreach my $count (0 .. $s_len)
$self->{'debug'}->DEBUG(['End ANSI Output']);
return (TRUE);
} ## end sub ansi_output
sub ansi_initialize {
my $self = shift;
$self->{'debug'}->DEBUG(['Start ANSI Initialize']);
# Helper builders to compact the meta spec
my $pairs_to_map = sub { # [name, out, desc] -> { name => { out, desc } }
my (@defs) = @_;
return { map { $_->[0] => { out => $_->[1], desc => $_->[2] } } @defs };
};
###
# Special sequences
my $special = $pairs_to_map->(
['APC', "\e_", 'Application Program Command'],
['SS2', "\eN", 'Single Shift 2'],
['SS3', "\eO", 'Single Shift 3'],
['CSI', "\e[", 'Control Sequence Introducer'],
['OSC', "\e]", 'Operating System Command'],
['SOS', "\eX", 'Start Of String'],
['ST', "\e\\", 'String Terminator'],
['DCS', "\eP", 'Device Control String'],
);
# Clear controls
my $clear = $pairs_to_map->(
['CLS', "\e[2J\e[H", 'Clear screen and place cursor at the top of the screen'],
['CLEAR', "\e[2J", 'Clear screen and keep cursor location'],
['CLEAR LINE', "\e[0K", 'Clear the current line from cursor'],
['CLEAR DOWN', "\e[0J", 'Clear from cursor position to bottom of the screen'],
['CLEAR UP', "\e[1J", 'Clear to the top of the screen from cursor position'],
);
# Cursor movement and control
my $cursor = $pairs_to_map->(
['BACKSPACE', chr(8), 'Backspace'],
['RETURN', chr(13), 'Carriage Return (ASCII 13)'],
['LINEFEED', chr(10), 'Line feed (ASCII 10)'],
['NEWLINE', chr(13) . chr(10), 'New line (ASCII 13 and ASCII 10)'],
['HOME', "\e[H", 'Place cursor at top left of the screen'],
['UP', "\e[A", 'Move cursor up one line'],
['DOWN', "\e[B", 'Move cursor down one line'],
['RIGHT', "\e[C", 'Move cursor right one space non-destructively'],
['LEFT', "\e[D", 'Move cursor left one space non-destructively'],
['NEXT LINE', "\e[E", 'Place the cursor at the beginning of the next line'],
['PREVIOUS LINE', "\e[F", 'Place the cursor at the beginning of the previous line'],
['SAVE', "\e[s", 'Save cureent cursor position'],
['RESTORE', "\e[u", 'Restore the cursor to the saved position'],
['CURSOR ON', "\e[?25h", 'Turn the cursor on'],
['CURSOR OFF', "\e[?25l", 'Turn the cursor off'],
['SCREEN 1', "\e[?1049l", 'Set display to screen 1'],
['SCREEN 2', "\e[?1049h", 'Set display to screen 2'],
);
# Text attributes
my $attributes = $pairs_to_map->(
['FONT 1', "\e[1m", 'ANSI FONT 1'],
['FONT 2', "\e[2m", 'ANSI FONT 2'],
['FONT 3', "\e[3m", 'ANSI FONT 3'],
['FONT 4', "\e[4m", 'ANSI FONT 4'],
['FONT 5', "\e[5m", 'ANSI FONT 5'],
['FONT 6', "\e[6m", 'ANSI FONT 6'],
['FONT 7', "\e[7m", 'ANSI FONT 7'],
['FONT 8', "\e[8m", 'ANSI FONT 8'],
['FONT 9', "\e[9m", 'ANSI FONT 9'],
['FONT DOUBLE-HEIGHT TOP', "\e#3", 'Double-Height Font Top Portion'],
['FONT DOUBLE-HEIGHT BOTTOM', "\e#4", 'Double-Height Font Bottom Portion'],
['FONT DOUBLE-WIDTH', "\e#6", 'Double-Width Font'],
['FONT DEFAULT SIZE', "\e#5", 'Default Font Size'],
['RESET', "\e[0m", 'Restore all attributes and colors to their defaults'],
['BOLD', "\e[1m", 'Set to bold text'],
['NORMAL', "\e[22m", 'Turn off all attributes'],
['FAINT', "\e[2m", 'Set to faint (light) text'],
['ITALIC', "\e[3m", 'Set to italic text'],
['UNDERLINE', "\e[4m", 'Set to underlined text'],
['DEFAULT UNDERLINE COLOR', "\e[59m", 'Set underline color to the default'],
['FRAMED', "\e[51m", 'Turn on framed text'],
['FRAMED OFF', "\e[54m", 'Turn off framed text'],
['ENCIRCLED', "\e[52m", 'Turn on encircled letters'],
['ENCIRCLED OFF', "\e[54m", 'Turn off encircled letters'],
['OVERLINED', "\e[53m", 'Turn on overlined text'],
['OVERLINED OFF', "\e[55m", 'Turn off overlined text'],
['SUPERSCRIPT', "\e[73m", 'Turn on superscript'],
['SUBSCRIPT', "\e[74m", 'Turn on superscript'],
['SUPERSCRIPT OFF', "\e[75m", 'Turn off superscript'],
['SUBSCRIPT OFF', "\e[75m", 'Turn off subscript'],
['SLOW BLINK', "\e[5m", 'Set slow blink'],
['RAPID BLINK', "\e[6m", 'Set rapid blink'],
['INVERT', "\e[7m", 'Invert text'],
['REVERSE', "\e[7m", 'Invert text'],
['HIDE', "\e[8m", 'Hide enclosed text'],
['REVEAL', "\e[28m", 'Reveal hidden text'],
['CROSSED OUT', "\e[9m", 'Crossed out text'],
['FONT DEFAULT', "\e[10m", 'Set default font'],
['PROPORTIONAL ON', "\e[26m", 'Turn on proportional text'],
['PROPORTIONAL OFF', "\e[50m", 'Turn off proportional text'],
['RING BELL', chr(7), 'Console bell'],
);
# Foreground (base 16 + bright variants)
my @fg16 = (
['DEFAULT', "\e[39m", 'Default foreground color'],
['BLACK', "\e[30m", 'Black'],
['RED', "\e[31m", 'Red'],
['GREEN', "\e[32m", 'Green'],
['YELLOW', "\e[33m", 'Yellow'],
['BLUE', "\e[34m", 'Blue'],
['MAGENTA', "\e[35m", 'Magenta'],
['CYAN', "\e[36m", 'Cyan'],
['WHITE', "\e[37m", 'White'],
lib/BBS/Universal.pm view on Meta::CPAN
['WILD BLUE YONDER', "\e[38;2;162;173;208m", 'Wild blue yonder'],
['WINE', "\e[38;2;114;47;55m", 'Wine'],
['WISTERIA', "\e[38;2;201;160;220m", 'Wisteria'],
['XANADU', "\e[38;2;115;134;120m", 'Xanadu'],
['YALE BLUE', "\e[38;2;15;77;146m", 'Yale Blue'],
['YELLOW ORANGE', "\e[38;2;255;174;66m", 'Yellow Orange'],
['YELLOW GREEN', "\e[38;2;154;205;50m", 'Yellow green'],
['ZAFFRE', "\e[38;2;0;20;168m", 'Zaffre'],
['ZINNWALDITE BROWN', "\e[38;2;44;22;8m", 'Zinnwaldite brown'],
);
foreach my $count (16 .. 231) {
push(@fg_extra, ["COLOR $count", "\e[38;5;${count}m", "ANSI 8 bit color $count"]);
}
foreach my $gray (232 .. 255) {
push(@fg_extra, ['GRAY ' . ($gray - 232), "\e[38;5;${gray}m", 'ANSI gray level ' . ($gray - 232)]);
}
my $foreground = $pairs_to_map->(
map { [ $_->[0], $_->[1], $_->[2] ] } @fg16,
map { [ $_->[0], $_->[1], $_->[2] ] } @fg_extra,
);
# Background (base 16 + bright variants)
my @bg16 = (
['B_BLACK', "\e[40m", 'Black'],
['B_BLUE', "\e[44m", 'Blue'],
['B_BRIGHT BLACK', "\e[100m", 'Bright black'],
['B_BRIGHT BLUE', "\e[104m", 'Bright blue'],
['B_BRIGHT CYAN', "\e[106m", 'Bright cyan'],
['B_BRIGHT GREEN', "\e[102m", 'Bright green'],
['B_BRIGHT MAGENTA', "\e[105m", 'Bright magenta'],
['B_BRIGHT RED', "\e[101m", 'Bright red'],
['B_BRIGHT WHITE', "\e[107m", 'Bright white'],
['B_BRIGHT YELLOW', "\e[103m", 'Bright yellow'],
['B_CYAN', "\e[46m", 'Cyan'],
['B_DEFAULT', "\e[49m", 'Default background color'],
['B_GREEN', "\e[42m", 'Green'],
['B_MAGENTA', "\e[45m", 'Magenta'],
['B_RED', "\e[41m", 'Red'],
['B_WHITE', "\e[47m", 'White'],
['B_YELLOW', "\e[43m", 'Yellow'],
);
###
# Derive full background extras from foreground extras by swapping 38 -> 48 in SGR
my @bg_extra = map {
my ($name, $code, $desc) = @$_;
my $bg_code = $code;
$bg_code =~ s/\[38;/[48;/;
[ "B_${name}", $bg_code, $desc ]
} @fg_extra;
my $background = $pairs_to_map->(
map { [ $_->[0], $_->[1], $_->[2] ] } @bg16,
map { [ $_->[0], $_->[1], $_->[2] ] } @bg_extra,
);
$self->{'ansi_meta'} = {
special => $special,
clear => $clear,
cursor => $cursor,
attributes => $attributes,
foreground => $foreground,
background => $background,
};
$self->{'debug'}->DEBUG(['End ANSI Initialize']);
return($self);
} ## end sub ansi_initialize
# package BBS::Universal::ASCII;
sub ascii_initialize {
my $self = shift;
$self->{'debug'}->DEBUG(['Start ASCII Initialize']);
$self->{'ascii_meta'} = {
'RETURN' => { 'out' => chr(13), 'unicode' => ' ', 'desc' => 'Carriage Return' },
'LINEFEED' => { 'out' => chr(10), 'unicode' => ' ', 'desc' => 'Linefeed' },
'NEWLINE' => { 'out' => chr(13) . chr(10), 'unicode' => ' ', 'desc' => 'Newline' },
'BACKSPACE' => { 'out' => chr(8), 'unicode' => ' ', 'desc' => 'Backspace' },
'TAB' => { 'out' => chr(9), 'unicode' => ' ', 'desc' => 'Tab' },
'DELETE' => { 'out' => chr(127), 'unicode' => ' ', 'desc' => 'Delete' },
'CLS' => { 'out' => chr(12), 'unicode' => ' ', 'desc' => 'Clear Screen (Formfeed)' },
'CLEAR' => { 'out' => chr(12), 'unicode' => ' ', 'desc' => 'Clear Screen (Formfeed)' },
'RING BELL' => { 'out' => chr(7), 'unicode' => ' ', 'desc' => 'Console Bell' },
};
$self->{'debug'}->DEBUG(['End ACSII Initialize']);
return ($self);
} ## end sub ascii_initialize
sub ascii_output {
my $self = shift;
my $text = shift;
$self->{'debug'}->DEBUG(['Start ASCII Output']);
my $mlines = (exists($self->{'USER'}->{'max_rows'})) ? $self->{'USER'}->{'max_rows'} - 3 : 21;
my $lines = $mlines;
if (length($text) > 1) {
foreach my $string (keys %{ $self->{'ascii_meta'} }) {
if ($string =~ /CLEAR|CLS/i && ($self->{'sysop'} || $self->{'local_mode'})) {
my $ch = locate(($self->{'CACHE'}->get('START_ROW') + $self->{'CACHE'}->get('ROW_ADJUST')), 1) . cldown;
$text =~ s/\[\%\s+$string\s+\%\]/$ch/gi;
} else {
$text =~ s/\[\%\s+$string\s+\%\]/$self->{'ascii_meta'}->{$string}->{'out'}/gi;
}
} ## end foreach my $string (keys %{...})
while ($text =~ /\[\%\s+HORIZONTAL RULE\s+\%\]/) {
my $rule = '=' x $self->{'USER'}->{'max_columns'};
$text =~ s/\[\%\s+HORIZONTAL RULE\s+\%\]/$rule/gs;
}
} ## end if (length($text) > 1)
my $s_len = length($text);
my $nl = $self->{'ascii_meta'}->{'NEWLINE'}->{'out'};
foreach my $count (0 .. $s_len) {
my $char = substr($text, $count, 1);
if ($char eq "\n") {
if ($text !~ /$nl/ && !$self->{'local_mode'}) { # translate only if the file doesn't have ASCII newlines
$char = $nl;
lib/BBS/Universal.pm view on Meta::CPAN
} ## end if ($count > $srow)
} ## end while (scalar(@{$left_ref...}))
return $table->twin('ORANGE')->draw();
} ## end sub _render_table
# Helper: substitutions registry
sub _substitutions_for_mode {
my ($mode) = @_;
return [
# Common header highlight
[qr/ (C|DESCRIPTION|TYPE|SYSOP MENU COMMANDS|SYSOP TOKENS|USER MENU COMMANDS|USER TOKENS|ATASCII TOKENS|PETSCII TOKENS|ASCII TOKENS) /, ' [% BRIGHT YELLOW %]$1[% RESET %] '],
# USER/SYSOP italicize "color" and "text"
($mode =~ /USER|SYSOP/ ? ([qr/color/, '[% ITALIC %][% FAINT %]color[% RESET %]'], [qr/text/, '[% ITALIC %][% FAINT %]text[% RESET %]'],) : ()),
# PETSCII color names mapped to ANSI
($mode eq 'PETSCII' ? ([qr/│ (WHITE)/, '│ [% BRIGHT WHITE %]$1[% RESET %]'], [qr/│ (YELLOW)/, '│ [% YELLOW %]$1[% RESET %]'], [qr/│ (CYAN)/, '│ [% CYAN %]$1[% RESET %]'], [qr/│ (GREEN)/, '│ [% GREEN %]$1[% RESET %]'], [qr/│ ...
];
} ## end sub _substitutions_for_mode
sub _apply_substitutions {
my ($text, $rules) = @_;
for my $rule (@$rules) {
my ($re, $rep) = @$rule;
$text =~ s/$re/$rep/g;
}
return $text;
} ## end sub _apply_substitutions
# Optional: isolate the very large ANSI catalog builder to its own function (preserving behavior)
sub _render_ansi_catalog {
my ($self, $wsize) = @_;
# This preserves the original logic and content, but organizes the huge string building
# into manageable sections. The content below is copied verbatim from your ANSI branch,
# with only structural arrangement and minor variable scoping cleanups.
# Header banner
my $text .= '[% BRIGHT GREEN %]â•' . '─' x 122 . 'â•®[% RESET %]' . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] _ _ _ ____ ___ _____ ___ _ _______ _ _ ____ [% BRIGHT GREEN %]│[% RESET %]} . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] / \ | \ | / ___|_ _| |_ _/ _ \| |/ / ____| \ | / ___| [% BRIGHT GREEN %]│[% RESET %]} . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] / _ \ | \| \___ \| | | || | | | ' /| _| | \| \___ \ [% BRIGHT GREEN %]│[% RESET %]} . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] / ___ \| |\ |___) | | | || |_| | . \| |___| |\ |___) | [% BRIGHT GREEN %]│[% RESET %]} . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] /_/ \_\_| \_|____/___| |_| \___/|_|\_\_____|_| \_|____/ [% BRIGHT GREEN %]│[% RESET %]} . "\n";
$text .= q{[% BRIGHT GREEN %]│[% BRIGHT WHITE %] [% BRIGHT GREEN %]│[% RESET %]} . "\n";
my $bar = '[% BRIGHT GREEN %]│[% RESET %]';
# CLEAR section
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]CLEAR [% RESET %][% BRIGHT GREEN %]' . 'â•' x 56 . '╤' . 'â•' x 56 . 'â•¡[% RESET %]' . "\n";
{
my @names = (sort(keys %{ $self->{'ansi_meta'}->{'clear'} }));
while (scalar(@names)) {
my $name = shift(@names);
$text .= '[% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-63s', $name) . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', $self->ansi_description('clear', $name)) . ' [% BRIGHT GREEN %]│[% RESET %]' . "\n";
}
}
# CURSOR section
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]CURSOR [% RESET %][% BRIGHT GREEN %]' . 'â•' x 55 . '╪' . 'â•' x 56 . 'â•¡[% RESET %]' . "\n";
{
my @names = (sort(keys %{ $self->{'ansi_meta'}->{'cursor'} }));
while (scalar(@names)) {
my $name = shift(@names);
$text .= "$bar " . sprintf('%-63s', $name) . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', $self->ansi_description('cursor', $name)) . " $bar\n";
}
$text .= "$bar " . sprintf('%-63s', 'LOCATE column,row') . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', 'Sets the cursor location') . " $bar\n";
$text .= "$bar " . sprintf('%-63s', 'SCROLL UP count') . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', 'Scrolls the screen up by "count" lines') . " $bar\n";
$text .= "$bar " . sprintf('%-63s', 'SCROLL DOWN count') . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', 'Scrolls the screen down by "count" lines') . " $bar\n";
}
# ATTRIBUTES section
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]ATTRIBUTES [% RESET %][% BRIGHT GREEN %]' . 'â•' x 51 . '╪' . 'â•' x 56 . 'â•¡[% RESET %]' . "\n";
{
my @names = grep(!/FONT \d/, (sort(keys %{ $self->{'ansi_meta'}->{'attributes'} })));
foreach my $name (@names) {
if ($name =~ /FONT|HIDE|RING BELL/) {
$text .= "$bar " . sprintf('%-63s', $name) . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', $self->ansi_description('attributes', $name)) . " $bar\n";
$text .= "$bar " . sprintf('%-63s', 'FONT 1-9') . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', 'Set specific font (1-9)') . " $bar\n" if ($name eq 'FONT DEFAULT');
} else {
$text .= '[% BRIGHT GREEN %]│[% RESET %][% ' . $name . ' %]' . sprintf(' %-63s', $name) . ' [% RESET %][% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', $self->ansi_description('attributes', $name)) . " $bar\n";
}
} ## end foreach my $name (@names)
$text .= "$bar " . sprintf('%-62s', 'UNDERLINE COLOR RGB red,green,blue ') . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s', 'Set the underline color using RGB') . " $bar\n";
}
# Colors
{
my $f;
my $b;
foreach my $code ('ANSI 3 BIT','ANSI 4 BIT','ANSI 8 BIT','ANSI 24 BIT') {
if ($code eq 'ANSI 3 BIT') {
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]' . sprintf('%-11s',$code) . ' [% RESET %][% BRIGHT GREEN %]â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•¤â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•...
} else {
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]' . sprintf('%-11s',$code) . ' [% RESET %][% BRIGHT GREEN %]â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•ªâ•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•...
}
if ($code eq 'ANSI 8 BIT') {
foreach my $count (16 .. 231) {
$text .= '[% BRIGHT GREEN %]│[% RESET %][% COLOR ' . $count . ' %]' . sprintf(' %-29s ',"COLOR $count") . '[% RESET %][% BRIGHT GREEN %]│[% RESET %][% BLACK %][% B_COLOR ' . $count . ' %]' . sprintf(' %-31s ', "B_COLOR $count") . '[% RESET %...
}
foreach my $count (0 .. 23) {
$text .= '[% BRIGHT GREEN %]│[% RESET %][% GRAY ' . $count . ' %]' . sprintf(' %-29s ', "GRAY $count") . '[% RESET %][% BRIGHT GREEN %]│[% RESET %][% BLACK %][% B_GRAY ' . $count . ' %]' . sprintf(' %-31s ', "B_GRAY $count") . '[% RESET %][%...
}
}
foreach my $name (grep(!/COLOR |GRAY /,sort(keys %{$self->{'ansi_meta'}->{'foreground'}}))) {
if ($self->ansi_type($self->{'ansi_meta'}->{'foreground'}->{$name}->{'out'}) eq $code) {
if ($name =~ /^(DEFAULT|NAVY|COLOR 16|BLACK|MEDIUM BLUE|ARMY GREEN|BISTRE|BULGARIAN ROSE|CHARCOAL|COOL BLACK|DARK BLUE|DARK GREEN|DARK JUNGLE GREEN|DARK MIDNIGHT BLUE|DUKE BLUE|EGYPTIAN BLUE|MEDIUM JUNGLE GREEN|MIDNIGHT BLUE|NAVY BLUE|ONYX|OXFOR...
$text .= '[% BRIGHT GREEN %]│[% RESET %]' . sprintf(' %-29s ',$name) . '[% RESET %][% BRIGHT GREEN %]│[% RESET %][% B_' . $name . ' %]' . sprintf(' %-31s ', "B_${name}") . '[% RESET %]│' . sprintf(' %-54s ',$self->ansi_description('foregr...
} else {
$text .= '[% BRIGHT GREEN %]│[% RESET %][% ' . $name . ' %]' . sprintf(' %-29s ',$name) . '[% RESET %][% BRIGHT GREEN %]│[% RESET %][% BLACK %][% B_' . $name . ' %]' . sprintf(' %-31s ', "B_${name}") . '[% RESET %][% BRIGHT GREEN %]│[% RE...
}
}
}
}
$text .= '[% BRIGHT GREEN %]│[% RESET %]' . sprintf(' %-29s ','RGB red,green,blue') . '[% RESET %][% BRIGHT GREEN %]│[% RESET %]' . sprintf(' %-31s ', 'B_RGB red,green,blue') . '[% RESET %][% BRIGHT GREEN %]│[% RESET %]' . sprintf(' %-5...
}
# Special
$text .= '[% BRIGHT GREEN %]â•žâ•â• [% BOLD %][% BRIGHT YELLOW %]SPECIAL [% RESET %][% BRIGHT GREEN %]â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•§â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â...
{
my @names = (sort(keys %{$self->{'ansi_meta'}->{'special'}}));
while(scalar(@names)) {
my $name = shift(@names);
$text .= "$bar " . sprintf('%-63s',$name) . ' [% BRIGHT GREEN %]│[% RESET %] ' . sprintf('%-54s',$self->ansi_description('special',$name)) . " $bar\n";
}
$text .= '[% BRIGHT GREEN %]│ ─────────────────────────────────────────────────────────────── │ ─────â...
lib/BBS/Universal.pm view on Meta::CPAN
$row = shift;
$animate = shift;
}
my $key;
do {
$self->{'CACHE'}->set('SHOW_STATUS', FALSE);
ReadMode 'ultra-raw';
$key = ReadKey(0.25);
ReadMode 'restore';
$self->sysop_animate($row) if ($animate);
threads->yield();
$self->{'CACHE'}->set('SHOW_STATUS', TRUE);
} until (defined($key));
return ($key);
} ## end sub sysop_keypress
sub sysop_animate {
my $self = shift;
my $row = shift;
my @color = @{ $self->{'sysop_menu_colors'} };
my $text = "\e[s" . "\e[1;91H\e[48;2;0;0;96m\e[93m " . $self->clock() . " \e[" . $row++ . ";1H\e[" . $color[0] . "mâ—¥\e[" . ($color[0] + 10) . "m \e[0m\e[" . $color[0] . "m\e[7mâ—¥\e[0m" . "\e[" . $row++ . ";2H\e[" . $color[1] . "mâ—¥\e[" . ($co...
$self->{'CACHE'}->set('SHOW_STATUS', FALSE);
print $text;
$self->{'CACHE'}->set('SHOW_STATUS', TRUE);
my $l = pop(@color);
unshift(@color, $l);
$self->{'sysop_menu_colors'} = \@color;
} ## end sub sysop_animate
sub sysop_ip_address {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp IP Address']);
chomp(my $ip = `nice hostname -I`);
$self->{'debug'}->DEBUG([" SysOp IP Address: $ip", 'End SysOp IP Address']);
return ($ip);
} ## end sub sysop_ip_address
sub sysop_hostname {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp Hostname']);
chomp(my $hostname = `nice hostname`);
$self->{'debug'}->DEBUG([" SysOp Hostname: $hostname", 'End SysOp Hostname']);
return ($hostname);
} ## end sub sysop_hostname
sub sysop_locate_middle {
my $self = shift;
my $color = (scalar(@_)) ? shift : 'B_WHITE';
my ($wsize, $hsize, $wpixels, $hpixels) = GetTerminalSize();
my $middle = int($wsize / 2);
my $string;
if ($color =~ /^B_/) {
$string = "\r" . $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x $middle . $self->{'ansi_meta'}->{'background'}->{$color}->{'out'} . ' ' . $self->{'ansi_meta'}->{'attributes'}->{'RESET'}->{'out'};
} else {
$string = "\r" . $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x $middle . $self->{'ansi_meta'}->{'foreground'}->{$color}->{'out'} . ' ' . $self->{'ansi_meta'}->{'attributes'}->{'RESET'}->{'out'};
}
return ($string);
} ## end sub sysop_locate_middle
sub sysop_memory {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp Memory']);
my $memory = `nice free`;
my @mem = split(/\n$/, $memory);
my $output = '[% BLACK %][% B_GREEN %] ' . shift(@mem) . ' [% RESET %]' . "\n";
while (scalar(@mem)) {
$output .= shift(@mem) . "\n";
}
if ($output =~ /(Mem\: )/) {
my $ch = '[% BLACK %][% B_GREEN %] ' . $1 . ' [% RESET %]';
$output =~ s/Mem\: /$ch/;
}
if ($output =~ /(Swap\: )/) {
my $ch = '[% BLACK %][% B_GREEN %] ' . $1 . ' [% RESET %]';
$output =~ s/Swap\: /$ch/;
}
$self->{'debug'}->DEBUG(['End SysOp Memory']);
return ($output);
} ## end sub sysop_memory
sub sysop_true_false {
my $self = shift;
my $boolean = shift;
my $mode = shift;
$boolean = $boolean + 0;
if ($mode eq 'TF') {
return (($boolean) ? 'TRUE' : 'FALSE');
} elsif ($mode eq 'YN') {
return (($boolean) ? 'YES' : 'NO');
} elsif ($mode eq 'OO') {
return(($boolean) ? 'ON' : 'OFF');
}
return ($boolean);
} ## end sub sysop_true_false
sub sysop_list_users {
my $self = shift;
my $list_mode = shift;
$self->{'debug'}->DEBUG(['Start SysOp List Users']);
my ($wsize, $hsize, $wpixels, $hpixels) = GetTerminalSize();
my $table;
my $date_format = $self->configuration('DATE FORMAT');
$date_format =~ s/YEAR/\%Y/;
$date_format =~ s/MONTH/\%m/;
$date_format =~ s/DAY/\%d/;
my $name_width = 15;
my $value_width = $wsize - 22;
my $sth;
my @order;
my $sql;
if ($list_mode =~ /DETAILED/) {
lib/BBS/Universal.pm view on Meta::CPAN
my $ch = $1;
my $new = '[% BRIGHT YELLOW %]' . $ch . '[% RESET %]';
$text =~ s/ $ch / $new /gs;
}
$self->sysop_output($text . "\n");
$self->sysop_prompt('Choose ID (< = Nevermind)');
my $line;
do {
$line = uc($self->sysop_get_line(ECHO, 3, ''));
} until ($line =~ /^(\d+|\<)/i);
my $response = FALSE;
if ($line >= 1 && $line <= $max_id) {
$sth = $self->{'dbh'}->prepare('UPDATE users SET file_category=? WHERE id=1');
$sth->execute($line);
$sth->finish();
$self->{'USER'}->{'file_category'} = $line + 0;
$response = TRUE;
} ## end if ($line >= 1 && $line...)
$self->{'debug'}->DEBUG(['End SysOp Select File Category']);
return ($response);
} ## end sub sysop_select_file_category
sub sysop_edit_file_categories {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp Edit File Categories']);
my $sth = $self->{'dbh'}->prepare('SELECT * FROM file_categories');
$sth->execute();
my $table = Text::SimpleTable->new(3, 30, 50);
$table->row('ID', 'TITLE', 'DESCRIPTION');
$table->hr();
while (my $row = $sth->fetchrow_hashref()) {
$table->row($row->{'id'}, $row->{'title'}, $row->{'description'});
}
$sth->finish();
my $text = $table->boxes->draw();
while ($text =~ / (ID|TITLE|DESCRIPTION) /) {
my $ch = $1;
my $new = '[% BRIGHT YELLOW %]' . $ch . '[% RESET %]';
$text =~ s/ $ch / $new /gs;
}
$self->sysop_output("$text\n");
$self->sysop_prompt('Choose ID (A = Add, < = Nevermind)');
my $line;
do {
$line = uc($self->sysop_get_line(ECHO, 3, ''));
} until ($line =~ /^(\d+|A|\<)/i);
if ($line eq 'A') { # Add
$self->{'debug'}->DEBUG([' SysOp Edit File Categories Add']);
print "\nADD NEW FILE CATEGORY\n";
$table = Text::SimpleTable->new(11, 80);
$table->row('TITLE', "\n" . charnames::string_vianame('OVERLINE') x 80);
$table->row('DESCRIPTION', "\n" . charnames::string_vianame('OVERLINE') x 80);
my $text = $table->twin('MAGENTA')->draw();
while ($text =~ / (TITLE|DESCRIPTION) /) {
my $ch = $1;
my $new = '[% BRIGHT YELLOW %]' . $ch . '[% RESET %]';
$text =~ s/ $ch / $new /gs;
}
$self->sysop_output("\n$text");
print $self->{'ansi_meta'}->{'cursor'}->{'UP'}->{'out'} x 5, $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x 16;
my $title = $self->sysop_get_line(ECHO, 80, '');
if ($title ne '') {
print "\r", $self->{'ansi_meta'}->{'cursor'}->{'DOWN'}->{'out'}, $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x 16;
my $description = $self->sysop_get_line(ECHO, 80, '');
if ($description ne '') {
$sth = $self->{'dbh'}->prepare('INSERT INTO file_categories (title,description) VALUES (?,?)');
$sth->execute($title, $description);
$sth->finish();
print "\n\nNew Entry Added\n";
} else {
print "\n\nNevermind\n";
}
} else {
print "\n\n\nNevermind\n";
}
} elsif ($line =~ /\d+/) { # Edit
$self->{'debug'}->DEBUG([' SysOp Edit File Categories Edit']);
}
$self->{'debug'}->DEBUG(['Start SysOp Edit File Categories']);
return (TRUE);
} ## end sub sysop_edit_file_categories
sub sysop_vertical_heading {
my $self = shift;
my $text = shift;
$self->{'debug'}->DEBUG(['Start SysOp Vertical Heading']);
my $heading = '';
for (my $count = 0; $count < length($text); $count++) {
$heading .= substr($text, $count, 1) . "\n";
}
$self->{'debug'}->DEBUG(['End SysOp Vertical Heading']);
return ($heading);
} ## end sub sysop_vertical_heading
sub sysop_view_configuration {
my $self = shift;
my $view = shift;
$self->{'debug'}->DEBUG(['Start SysOp View Configuration']);
# Get maximum widths
my $name_width = 6;
my $value_width = 80;
foreach my $cnf (keys %{ $self->configuration() }) {
if ($cnf eq 'STATIC') {
foreach my $static (keys %{ $self->{'CONF'}->{$cnf} }) {
$name_width = max(length($static), $name_width);
$value_width = max(length($self->{'CONF'}->{$cnf}->{$static}), $value_width);
}
} else {
$name_width = max(length($cnf), $name_width);
$value_width = max(length($self->{'CONF'}->{$cnf}), $value_width);
}
} ## end foreach my $cnf (keys %{ $self...})
# Assemble table
my $table = ($view) ? Text::SimpleTable->new($name_width, $value_width) : Text::SimpleTable->new(6, $name_width, $value_width);
if ($view) {
$table->row('STATIC NAME', 'STATIC VALUE');
$table->hr();
}
foreach my $conf (sort(keys %{ $self->{'CONF'}->{'STATIC'} })) {
lib/BBS/Universal.pm view on Meta::CPAN
'THREAD MULTIPLIER' => { 'max' => 2, 'type' => NUMERIC, },
'PORT' => { 'max' => 5, 'type' => NUMERIC, },
'DEFAULT BAUD RATE' => { 'max' => 5, 'type' => RADIO, 'choices' => ['300', '600', '1200', '2400', '4800', '9600', '19200', '38400', '57600', '115200', 'FULL'], },
'DEFAULT TEXT MODE' => { 'max' => 7, 'type' => RADIO, 'choices' => ['ANSI', 'ASCII', 'ATASCII', 'PETSCII'], },
'DEFAULT TIMEOUT' => { 'max' => 3, 'type' => NUMERIC, },
'FILES PATH' => { 'max' => 60, 'type' => STRING, },
'LOGIN TRIES' => { 'max' => 1, 'type' => NUMERIC, },
'MEMCACHED HOST' => { 'max' => 20, 'type' => HOST, },
'MEMCACHED NAMESPACE' => { 'max' => 32, 'type' => STRING, },
'MEMCACHED PORT' => { 'max' => 5, 'type' => NUMERIC, },
'DATE FORMAT' => { 'max' => 14, 'type' => RADIO, 'choices' => ['MONTH/DAY/YEAR', 'DAY/MONTH/YEAR', 'YEAR/MONTH/DAY',], },
'SYSOP ANIMATED MENU' => { 'max' => 5, 'type' => BOOLEAN, 'choices' => ['ON', 'OFF'], },
'USE DUF' => { 'max' => 5, 'type' => BOOLEAN, 'choices' => ['ON', 'OFF'], },
'PLAY SYSOP SOUNDS' => { 'max' => 5, 'type' => BOOLEAN, 'choices' => ['ON', 'OFF'], },
};
my $choice;
do {
$choice = uc($self->sysop_keypress());
} until ($choice =~ /[A-R]|Z/i);
if ($choice =~ /Z/i) {
print "BACK\n";
return (FALSE);
}
$choice = ("$choice" =~ /[A-Y]/i) ? $choice = (ord($choice) - 65) : $choice;
my @conf = grep(!/STATIC|AUTHOR/, sort(keys %{ $self->{'CONF'} }));
if ($types->{ $conf[$choice] }->{'type'} == RADIO || $types->{ $conf[$choice] }->{'type'} == BOOLEAN) {
print '(Edit) ', $conf[$choice], ' (' . join(' ', @{ $types->{ $conf[$choice] }->{'choices'} }) . ') ', charnames::string_vianame('BLACK RIGHT-POINTING TRIANGLE'), ' ';
} else {
print '(Edit) ', $conf[$choice], ' ', charnames::string_vianame('BLACK RIGHT-POINTING TRIANGLE'), ' ';
}
my $string;
$self->{'debug'}->DEBUGMAX([$self->configuration()]);
$string = $self->sysop_get_line($types->{ $conf[$choice] }, $self->configuration($conf[$choice]));
my $response = TRUE;
if ($string eq '') {
$response = FALSE;
} else {
$self->configuration($conf[$choice], $string);
}
$self->{'debug'}->DEBUG(['End SysOp Edit Configuration']);
return ($response);
} ## end sub sysop_edit_configuration
sub sysop_get_key {
my $self = shift;
my $echo = shift;
my $blocking = shift;
my $key = undef;
my $mode = $self->{'USER'}->{'text_mode'};
my $timeout = $self->{'USER'}->{'timeout'} * 60;
local $/ = "\x{00}";
ReadMode 'ultra-raw';
$key = ($blocking) ? ReadKey($timeout) : ReadKey(-1);
ReadMode 'restore';
threads->yield;
return ($key) if ($key eq chr(13));
if ($key eq chr(127)) {
$key = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
}
if ($echo == NUMERIC && defined($key)) {
unless ($key =~ /[0-9]/) {
$key = '';
}
}
threads->yield;
return ($key);
} ## end sub sysop_get_key
sub sysop_get_line {
my $self = shift;
my $echo = shift;
my $type = $echo;
my $line;
my $limit;
my $choices;
my $key;
$self->{'CACHE'}->set('SHOW_STATUS', FALSE);
$self->{'debug'}->DEBUG(['Start SysOp Get Line']);
$self->flush_input();
if (ref($type) eq 'HASH') {
$limit = $type->{'max'};
if (exists($type->{'choices'})) {
$choices = $type->{'choices'};
if (exists($type->{'default'})) {
$line = $type->{'default'};
} else {
$line = shift;
}
} ## end if (exists($type->{'choices'...}))
$echo = $type->{'type'};
} else {
if ($echo == STRING || $echo == ECHO || $echo == NUMERIC || $echo == HOST) {
$limit = shift;
}
$line = shift;
} ## end else [ if (ref($type) eq 'HASH')]
chomp($line);
$self->{'debug'}->DEBUGMAX([$type, $echo, $line]);
print $line if ($line ne '');
my $mode = 'ANSI';
my $bs = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
if ($echo == RADIO) {
$self->{'debug'}->DEBUG([' SysOp Get Line RADIO']);
my $mapping;
my @menu_choices = @{$self->{'MENU CHOICES'}};
foreach my $choice (@{$choices}) {
$mapping->{ shift(@menu_choices) } = {
'command' => $choice,
'color' => 'WHITE',
'access_level' => 'USER',
'text' => $choice,
}
}
print "\n";
$self->sysop_show_choices($mapping);
$self->sysop_prompt('Choose');
my $key;
do {
$key = uc($self->sysop_get_key(SILENT, BLOCKING));
} until (exists($mapping->{$key}) || $key eq chr(3));
if ($key eq chr(3)) {
$line = '';
} else {
$line = $mapping->{$key}->{'command'};
}
} elsif ($echo == BOOLEAN) {
$self->{'debug'}->DEBUG([' SysOp Get Line BOOLEAN']);
do {
$key = $self->sysop_get_key(SILENT, BLOCKING);
if (uc($key) eq 'T') {
$line = 'ON';
print $self->{'ansi_meta'}->{'cursor'}->{'LEFT'}->{'out'} x 5, 'ON', clline;
} elsif (uc($key) eq 'F') {
$line = 'OFF';
print $self->{'ansi_meta'}->{'cursor'}->{'LEFT'}->{'out'} x 4, 'OFF', clline;
} elsif ($key ne chr(13) && $key ne chr(3)) {
print chr(7);
}
} until ($key eq chr(13) or $key eq chr(3));
} elsif ($echo == NUMERIC) {
$self->{'debug'}->DEBUG([' SysOp Get Line NUMERIC']);
while ($key ne chr(13) && $key ne chr(3)) {
if (length($line) <= $limit) {
$key = $self->sysop_get_key(NUMERIC, BLOCKING);
return ('') if (defined($key) && $key eq chr(3));
if (defined($key) && $key ne '') {
if ($key eq $bs || $key eq chr(127)) {
my $len = length($line);
if ($len > 0) {
print "$key $key";
chop($line);
}
} elsif ($key ne chr(13) && $key ne chr(3) && $key ne chr(10) && $key =~ /[0-9]/) {
print $key;
$line .= $key;
} else {
print chr(7);
}
} ## end if (defined($key) && $key...)
} else {
$key = $self->sysop_get_key(SILENT, BLOCKING);
if (defined($key) && $key eq chr(3)) {
return ('');
}
if (defined($key) && ($key eq $bs || $key eq chr(127))) {
$key = $bs;
print "$key $key";
chop($line);
} else {
print chr(7);
}
} ## end else [ if (length($line) <= $limit)]
} ## end while ($key ne chr(13) &&...)
} elsif ($echo == HOST) {
$self->{'debug'}->DEBUG([' SysOp Get Line HOST']);
while ($key ne chr(13) && $key ne chr(3)) {
if (length($line) <= $limit) {
$key = $self->sysop_get_key(SILENT, BLOCKING);
return ('') if (defined($key) && $key eq chr(3));
if (defined($key) && $key ne '') {
if ($key eq $bs || $key eq chr(127)) {
my $len = length($line);
if ($len > 0) {
$self->sysop_output("$key $key");
chop($line);
}
} elsif ($key ne chr(13) && $key ne chr(3) && $key ne chr(10) && $key =~ /[a-z]|[0-9]|\./) {
print lc($key);
$line .= lc($key);
} else {
print chr(7);
}
} ## end if (defined($key) && $key...)
} else {
$key = $self->sysop_get_key(SILENT, BLOCKING);
lib/BBS/Universal.pm view on Meta::CPAN
my $bbs = $sth->fetchrow_hashref();
$sth->finish();
my $table = Text::SimpleTable->new(6, 12, 50);
my $index = 1;
$table->row('CHOICE', 'FIELD NAME', 'VALUE');
$table->hr();
foreach my $name (qw(bbs_id bbs_poster bbs_name bbs_hostname bbs_port)) {
if ($name =~ /bbs_id|bbs_poster/) {
$table->row(' ', $name, $bbs->{$name});
} else {
$table->row($index, $name, $bbs->{$name});
$index++;
}
} ## end foreach my $name (qw(bbs_id bbs_poster bbs_name bbs_hostname bbs_port))
$self->sysop_output($table->round('BRIGHT BLUE')->draw());
$self->sysop_prompt('Edit which field (Z=Nevermind)');
my $choice;
do {
$choice = $self->sysop_keypress();
} until ($choice =~ /[1-3]|Z/i);
if ($choice =~ /\D/) {
print "BACK\n";
return (FALSE);
}
$self->sysop_prompt($choices[$choice] . ' (' . $bbs->{ $choices[$choice] } . ') ');
my $width = ($choices[$choice] eq 'bbs_port') ? 5 : 50;
my $new = $self->sysop_get_line(ECHO, $width, '');
if ($new eq '') {
$self->{'debug'}->DEBUG(['sysop_edit_bbs end']);
return (FALSE);
}
$sth = $self->{'dbh'}->prepare('UPDATE bbs_listing SET ' . $choices[$choice] . '=? WHERE bbs_id=?');
$sth->execute($new, $bbs->{'bbs_id'});
$sth->finish();
} else {
$sth->finish();
}
$self->{'debug'}->DEBUG(['End SysOp Edit BBS']);
return (TRUE);
} ## end sub sysop_edit_bbs
sub sysop_add_bbs {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp Add BBS']);
my $table = Text::SimpleTable->new(14, 50);
foreach my $name ('BBS NAME', 'HOSTNAME/PHONE', 'PORT') {
my $count = ($name eq 'PORT') ? 5 : 50;
$table->row($name, "\n" . charnames::string_vianame('OVERLINE') x $count);
$table->hr() unless ($name eq 'PORT');
}
my @order = (qw(bbs_name bbs_hostname bbs_port));
my $bbs = {
'bbs_name' => '',
'bbs_hostname' => '',
'bbs_port' => '',
};
my $index = 0;
my $response = TRUE;
$self->sysop_output($table->round('BRIGHT BLUE')->draw());
print $self->{'ansi_meta'}->{'cursor'}->{'UP'}->{'out'} x 9, $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x 19;
$bbs->{'bbs_name'} = $self->sysop_get_line(ECHO, 50, '');
$self->{'debug'}->DEBUG([' BBS Name: ' . $bbs->{'bbs_name'}]);
if ($bbs->{'bbs_name'} ne '' && length($bbs->{'bbs_name'}) > 3) {
print $self->{'ansi_meta'}->{'cursor'}->{'DOWN'}->{'out'} x 2, "\r", $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x 19;
$bbs->{'bbs_hostname'} = $self->sysop_get_line(ECHO, 50, '');
$self->{'debug'}->DEBUG([' BBS Hostname: ' . $bbs->{'bbs_hostname'}]);
if ($bbs->{'bbs_hostname'} ne '' && length($bbs->{'bbs_hostname'}) > 5) {
print $self->{'ansi_meta'}->{'cursor'}->{'DOWN'}->{'out'} x 2, "\r", $self->{'ansi_meta'}->{'cursor'}->{'RIGHT'}->{'out'} x 19;
$bbs->{'bbs_port'} = $self->sysop_get_line(ECHO, 5, '');
$self->{'debug'}->DEBUG([' BBS Port: ' . $bbs->{'bbs_port'}]);
if ($bbs->{'bbs_port'} ne '' && $bbs->{'bbs_port'} =~ /^\d+$/) {
$self->{'debug'}->DEBUG([' Add to BBS List']);
my $sth = $self->{'dbh'}->prepare('INSERT INTO bbs_listing (bbs_name,bbs_hostname,bbs_port,bbs_poster_id) VALUES (?,?,?,1)');
$sth->execute($bbs->{'bbs_name'}, $bbs->{'bbs_hostname'}, $bbs->{'bbs_port'});
$sth->finish();
} else {
$response = FALSE;
}
} else {
$response = FALSE;
}
} else {
$response = FALSE;
}
$self->{'debug'}->DEBUG(['End SysOp Add BBS']);
return ($response);
} ## end sub sysop_add_bbs
sub sysop_delete_bbs {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp Delete BBS']);
$self->sysop_prompt('Please enter the ID, the hostname, or the BBS name to delete');
my $search;
$search = $self->sysop_get_line(ECHO, 50, '');
if ($search eq '') {
return (FALSE);
}
print "\r", cldown, "\n";
my $sth = $self->{'dbh'}->prepare('SELECT * FROM bbs_listing_view WHERE bbs_id=? OR bbs_name=? OR bbs_hostname=?');
$sth->execute($search, $search, $search);
if ($sth->rows() > 0) {
my $bbs = $sth->fetchrow_hashref();
$sth->finish();
my $table = Text::SimpleTable->new(12, 50);
$table->row('FIELD NAME', 'VALUE');
$table->hr();
foreach my $name (qw(bbs_id bbs_poster bbs_name bbs_hostname bbs_port)) {
$table->row($name, $bbs->{$name});
}
$self->sysop_output($table->round('RED')->draw());
print 'Are you sure that you want to delete this BBS from the list (Y|N)? ';
my $choice = $self->sysop_decision();
unless ($choice) {
$self->{'debug'}->DEBUG(['End SysOp Delete BBS']);
return (FALSE);
}
$sth = $self->{'dbh'}->prepare('DELETE FROM bbs_listing WHERE bbs_id=?');
$sth->execute($bbs->{'bbs_id'});
} ## end if ($sth->rows() > 0)
$sth->finish();
$self->{'debug'}->DEBUG(['End SysOp Delete BBS']);
return (TRUE);
} ## end sub sysop_delete_bbs
sub sysop_add_file_category {
my $self = shift;
lib/BBS/Universal.pm view on Meta::CPAN
} ## end if (defined($title) &&...)
} ## end if (-e $filename)
} ## end while (scalar(@names))
} else {
$self->sysop_output("\n\n" . '[% BRIGHT RED %]NO FILES TO ADD![% RESET %] ');
sleep 2;
}
} else {
print colored(['yellow'], 'No unmapped files found'), "\n";
sleep 2;
}
$self->{'debug'}->DEBUG(['End SysOp Add File']);
} ## end sub sysop_add_file
sub sysop_bbs_list_bulk_import {
my $self = shift;
my $filename = $self->configuration('BBS ROOT') . "/bbs_list.txt";
$self->{'debug'}->DEBUG(['Start SysOp BBS List Bulk Import of ' . $filename]);
if (-e "$filename") {
$self->sysop_output("\n\nImporting/merging BBS list from bbs_list.txt\n\n");
$self->sysop_output('[% GREEN %]â•â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”¬â”€...
$self->sysop_output('[% GREEN %]│[% RESET %] NAME [% GREEN %]│[% RESET %] HOSTNAME/PHONE [% GREEN %]│[% RESET %] PORT [% GREEN %]│[% RESET %]' . "\n");
$self->sysop_output('[% GREEN %]├───────────────────────────────────────────────────────────────────┼─...
open(my $FILE, '<', $filename);
chomp(my @bbs = <$FILE>);
close($FILE);
my $sth = $self->{'dbh'}->prepare('REPLACE INTO bbs_listing (bbs_name,bbs_hostname,bbs_port,bbs_poster_id) VALUES (?,?,?,?)');
foreach my $row (@bbs) {
if ($row =~ /^. \S/ && $row !~ /^\* = NEW/) {
$row =~ s/^\* / /;
my ($name, $url) = (substr($row, 2, 41), substr($row, 43));
$name =~ s/(.*?)\s+$/$1/;
my ($address, $port) = split(/:/, $url);
$port = 23 unless (defined($port));
$sth->execute($name, $address, $port, $self->{'USER'}->{'id'});
$self->sysop_output('[% GREEN %]│[% RESET %] ' . sprintf('%-65s', $name) . '[% GREEN %] │[% RESET %] ' . sprintf('%-32s', $address) . ' [% GREEN %]│[% RESET %] ' . sprintf('%5d', $port) . ' [% GREEN %]│[% RESET %]' . "\n");
} ## end if ($row =~ /^. \S/ &&...)
} ## end foreach my $row (@bbs)
$sth->finish();
$self->sysop_output('[% GREEN %]╰───────────────────────────────────────────────────────────────────┴─...
} else {
print "\n", chr(7), colored(['red'], 'Cannot find '), $filename, "\n";
$self->{'debug'}->WARNING(["Cannot find $filename"]);
}
print "\nPress any key to continue";
$self->sysop_get_key(SILENT, BLOCKING);
$self->{'debug'}->DEBUG(['End SysOp BBS List Bulk Import']);
return (TRUE);
} ## end sub sysop_bbs_list_bulk_import
sub sysop_ansi_output {
my $self = shift;
$self->{'debug'}->DEBUG(['Start SysOp ANSI Output']);
my $mlines = (exists($self->{'USER'}->{'max_rows'})) ? $self->{'USER'}->{'max_rows'} - 3 : 21;
my $lines = $mlines;
my $text = $self->ansi_decode(shift);
my $s_len = length($text);
my $nl = $self->{'ansi_meta'}->{'cursor'}->{'NEWLINE'}->{'out'};
my @lines = split(/\n/, $text);
my $size = $self->{'USER'}->{'max_rows'};
while (scalar(@lines)) {
my $line = shift(@lines);
print $line;
$size--;
if ($size <= 0) {
$size = $self->{'USER'}->{'max_rows'};
last unless ($self->scroll(("\n")));
} else {
print "\n";
}
} ## end while (scalar(@lines))
$self->{'debug'}->DEBUG(['End SysOp ANSI Output']);
return (TRUE);
} ## end sub sysop_ansi_output
sub sysop_output {
my $self = shift;
$| = 1;
$self->{'debug'}->DEBUG(['Start SysOp Output']);
my $text = $self->detokenize_text(shift);
my $response = TRUE;
if (defined($text) && $text ne '') {
while ($text =~ /\[\%\s+WRAP\s+\%\](.*?)\[\%\s+ENDWRAP\s+\%\]/si) {
my $wrapped = $1;
my $format = Text::Format->new(
'columns' => $self->{'USER'}->{'max_columns'} - 1,
'tabstop' => 4,
'extraSpace' => TRUE,
'firstIndent' => 0,
);
$wrapped = $format->format($wrapped);
chomp($wrapped);
$text =~ s/\[\%\s+WRAP\s+\%\].*?\[\%\s+ENDWRAP\s+\%\]/$wrapped/s;
} ## end while ($text =~ /\[\%\s+WRAP\s+\%\](.*?)\[\%\s+ENDWRAP\s+\%\]/si)
while ($text =~ /\[\%\s+JUSTIFIED\s+\%\](.*?)\[\%\s+ENDJUSTIFIED\s+\%\]/si) {
my $wrapped = $1;
my $format = Text::Format->new(
'columns' => $self->{'USER'}->{'max_columns'} - 1,
'tabstop' => 4,
'extraSpace' => TRUE,
'firstIndent' => 0,
'justify' => TRUE,
);
$wrapped = $format->format($wrapped);
chomp($wrapped);
$text =~ s/\[\%\s+JUSTIFIED\s+\%\].*?\[\%\s+ENDJUSTIFIED\s+\%\]/$wrapped/s;
} ## end while ($text =~ /\[\%\s+JUSTIFIED\s+\%\](.*?)\[\%\s+ENDJUSTIFIED\s+\%\]/si)
$self->sysop_ansi_output($text);
} else {
$response = FALSE;
}
$self->{'debug'}->DEBUG(['End SysOp Output']);
return ($response);
} ## end sub sysop_output
( run in 2.887 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )