Kyoshiro/bip
1
0
Fork 0
forked from bip/bip
Code Pull Requests Activity
f2443aaf23
bip/scripts/bipgenconfig
Loïc Gomez 4cd5bdb381
Set default backlog_lines = 0 (fixes Debian bug #818374) 
This would have defaults move to backlog_always=false / log=true /
backlog_lines=0, which should not cause much trouble as backlog will
be reset after being displayed.

Also, it is doubtfuk anyone would be keeping the default of 10 for
backlog as it is pretty much an undesirable configuration.

We need to annouce this change as important though, so users having
log = false are aware memory usage could increase if they don't set
it manually to another value.

Signed-off-by: Loïc Gomez <bip@animanova.fr>
2024-02-17 03:29:45 +01:00

1740 lines
43 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/env perl
#
# This file is part of the bip project
# Copyright (C) 2004 2007 Arnaud Cornet and Loïc Gomez
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# See the file "COPYING" for the exact licensing terms.
#
use strict;
use IO::File;
use Data::Dumper;
my $bipdir = $ENV{'HOME'} . '/.bip';
my $CFILE = $bipdir . '/bip.conf.autogen';
my $sfile = $bipdir . '/bipgenconfig.store';
my $certout = $bipdir . '/bip.pem.autogen';
my $SERIALIZE_DBG = 1;
my %cf;
my $DEBUG = 0;
my $global_done = 0;
my $cert_done = 0;
my $mode = 'normal';
# maximum level of nested blocks { { { } } }
my $maxlevel = 5;
my $bipmkpw;
my $tmpcrt = "/tmp/bip-cert.cnf";
my %optcompat = (
"bl_msg_only" => "backlog_msg_only",
"blreset_on_talk" => "backlog_reset_on_talk",
"always_backlog" => "backlog_always",
);
my %optdesc = (
'global' => {
'ip' => { 'type' => 's', 'adv' => 1, 'default' => '0.0.0.0',
'optional' => 1,
'desc' => 'What IP address/hostname do you want bip to listen on ?' },
'port' => { 'type' => 'i', 'adv' => 1, 'default' => '7778',
'optional' => 1,
'desc' => 'What port do you want bip to listen on ?' },
'client_side_ssl' => { 'type' => 'b', 'adv' => 1, 'default' => 'true',
'optional' => 1,
'desc' => 'Do you want to enable client side SSL ?' },
'client_side_ssl_pem' => { 'type' => 's', 'adv' => 1, 'optional' => 1,
'default' => '',
'desc' => 'Where is the bip.pem file (cert/key pair) ?' },
'pid_file' => { 'type' => 's', 'adv' => 1, 'optional' => 1,
'default' => $bipdir . '/bip.pid',
'desc' => 'Where do you want the pidfile to be stored ?' },
'log' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'desc' => 'Do you want to enable channel logging ?' },
'log_system' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'desc' => 'Do you want to enable system logging ?' },
'log_sync_interval' => { 'type' => 'i', 'adv' => 1,
'optional' => 1,
'default' => '5', 'depends' => 'log', 'depval' => 'true',
'desc' => 'At which interval do you want bip to force logs to be written {seconds} ?' },
'log_level' => { 'type' => 'i', 'adv' => 1, 'default' => '3',
'optional' => 1,
'depends' => 'log', 'depval' => 'true',
'desc' => 'Define bip\'s system logs verbosity level {less 0 - 7 tremendous}:' },
'log_root' => { 'type' => 's', 'adv' => 0,
'optional' => 1,
'default' => $bipdir . '/logs',
'depends' => 'log', 'depval' => 'true',
'desc' => 'In which directory do you want logs to be stored ?' },
'log_format' => { 'type' => 's', 'adv' => 1, 'default' => '%n/%Y-%m/%c.%d.log',
'optional' => 1,
'depends' => 'log', 'depval' => 'true',
'desc' => 'Define the channel/private log format {see strftime, limited}:' },
},
'network' => {
'name' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'Network\'s name' },
'ssl' => { 'type' => 'b', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'Enable SSL for this network ?' },
'server' => { 'type' => 'e' },
},
'user' => {
'name' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'User\'s internal name ?' },
'admin' => { 'type' => 'b', 'adv' => 0, 'default' => 'false',
'optional' => 1,
'desc' => 'Is user an admin ?' },
'password' => { 'type' => 'p', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'Set a password for his bip account:' },
'bip_use_notice' => { 'type' => 'b', 'adv' => 0, 'default' => 'false',
'optional' => 1,
'desc' => 'Do you prefer bip to use notices instead of privmsgs ?' },
'ssl_check_mode' => { 'type' => 's', 'adv' => 1,
'optional' => 1, 'default' => 'none',
'desc' => 'Type of SSL servers certificate\'s checks' },
'ssl_check_store' => { 'type' => 's', 'adv' => 1,
'optional' => 1, 'default' => '',
'desc' => 'Path to SSL servers\'s data storage' },
'default_nick' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'User\'s default IRC nickname' },
'default_user' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'User\'s default IRC username' },
'default_realname' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'User\'s default IRC realname' },
'backlog' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'depends' => 'log', 'depval' => 'true',
'desc' => 'Do you want to activate backlog {play back logs} system ?' },
'backlog_lines' => { 'type' => 'i', 'adv' => 0, 'default' => '0',
'optional' => 1,
'depends' => 'backlog', 'depval' => 'true',
'desc' => 'How much line do you want bip to play back upon client connect' .
" {0 => replay everything since backlog's last reset} ?" },
'backlog_timestamp' => { 'type' => 's', 'adv' => 0,
'optional' => 1,
'default' => 'time', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Use time, datetime or disable prefix in backlog',
'values' => ['none', 'time', 'datetime'] },
'backlog_msg_only' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Only playback users messages {chan/priv}, no nick/join/... ?' },
'backlog_always' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Always backlog {false means backlog pointers are reset after each backlog} ?' },
'backlog_reset_on_talk' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Reset backlog each time an attached client "talks" ?' },
'connection' => { 'type' => 'e' },
},
'connection' => {
'name' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'Connection name (used by bip only)' },
'network' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0, 'postdepends' => 'networks.$value',
'desc' => 'Network to connect to' },
'defid' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1, 'nosave' => 1,
'desc' => 'Use default identity ?' },
'nick' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'depends' => 'defid', 'depval' => 'false',
'desc' => 'IRC nickname on this connection ?' },
'user' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'depends' => 'defid', 'depval' => 'false',
'desc' => 'IRC username on this connection ?' },
'realname' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'depends' => 'defid', 'depval' => 'false',
'desc' => 'IRC realname on this connection ?' },
'password' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'IRC server\'s password ?' },
'vhost' => { 'type' => 's', 'adv' => 1, 'default' => '',
'optional' => 1,
'desc' => 'Connect to IRC server from this specific IP address:' },
'source_port' => { 'type' => 'i', 'adv' => 1, 'default' => '',
'optional' => 1,
'desc' => 'Connect to IRC server from this specific port:' },
'follow_nick' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'desc' => 'Follow nicknames changes from clients to use upon reconnection (if false, bip\'ll use config nickname)' },
'ignore_first_nick' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'desc' => 'Ignore nickname change sent by a client (first one only, upon client attach)' },
'away_nick' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'Set nickname to this value when there\'s no more client attached:' },
'no_client_away_msg' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'Set this away message when there\'s no more client attached:' },
'on_connect_send' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'Send this raw message upon connection to IRC server' },
'ssl_check_mode' => { 'type' => 's', 'adv' => 1,
'optional' => 1, 'default' => '',
'desc' => 'Type of SSL servers certificate\'s checks' },
'channel' => { 'type' => 'e' },
},
'channel' => {
'name' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'Channel name' },
'key' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 1,
'desc' => 'Channel key (optional)' },
},
'server' => {
'host' => { 'type' => 's', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'IRC server\'s IP address/hostname' },
'port' => { 'type' => 'i', 'adv' => 0, 'default' => '6667',
'optional' => 0,
'desc' => 'IRC server\'s port' },
}
);
my %optorder = (
'global' => [
'ip' ,
'port' ,
'client_side_ssl' ,
'client_side_ssl_pem' ,
'pid_file' ,
undef,
'log' ,
'log_system' ,
'log_sync_interval' ,
'log_level' ,
'log_root' ,
'log_format' ,
],
'network' => [
'name' ,
'ssl' ,
'server' ,
],
'user' => [
'name' ,
'password' ,
'ssl_check_mode' ,
'ssl_check_store' ,
undef,
'default_nick' ,
'default_user' ,
'default_realname' ,
undef,
'backlog' ,
'backlog_lines' ,
'backlog_timestamp' ,
'backlog_msg_only' ,
'backlog_always' ,
'backlog_reset_on_talk' ,
'connection' ,
],
'connection' => [
'name' ,
'network' ,
'defid',
'nick' ,
'user' ,
'realname' ,
'password' ,
undef,
'vhost' ,
'source_port' ,
'follow_nick' ,
'ignore_first_nick' ,
'away_nick' ,
'no_client_away_msg' ,
'on_connect_send' ,
'ssl_check_mode' ,
'channel' ,
],
'channel' => [
'name' ,
'key' ,
],
'server' => [
'host' ,
'port' ,
]
);
my $clear_string = `clear`;
sub myexit {
warn("Error: $1");
warn("Saving configuration...");
save_config();
warn("Don't worry, your configuration has been saved ;)");
exit(1);
}
sub askOpt {
my ($e, $curval, $mayempty) = @_;
my ($o, $sel);
$sel = (($curval ne undef) ? $curval : $e->{'default'});
return $sel if ($mode eq 'normal' && $e->{'adv'} eq 1);
while (1) {
my $opt = (defined $e->{'optional'} && $e->{'optional'} eq 1 ?
1 : 0);
if ($e->{'type'} eq 'b') {
$o = askbool($e->{'desc'}, $sel, 1);
} elsif ($e->{'type'} eq 'p') {
$o = askPass($e->{'desc'});
} else {
$o = askval($e->{'desc'}, $sel, ($mayempty && ($opt ne 1 ||
$e->{'type'} eq 'i' ? 1 : undef)), 1);
if (defined $e->{'values'} && !grep(/^$o$/, @{$e->{'values'}})) {
print("The allowed values are '@{[ join '\', \'', @{$e->{'values'}} ]}'\n");
next;
}
}
if ($o eq undef && $opt eq 0) {
print("This value is mandatory, please enter a value\n");
next;
}
if ($e->{'type'} eq 'i' && $o !~ /^\d*$/) {
print("We want a number here, please enter one\n");
next;
}
last;
}
return $o;
}
sub align {
my ($text, $num) = @_;
my ($out, $pos, $orig);
$orig = $text;
while ($text ne '' || $text ne undef) {
$num = 60 if (!$num);
$pos = rindex($text, " ", 60);
$out .= "\n" if ($out);
$out .= substr($text, 0, $pos);
$text = substr($text, $pos+1);
}
$out .= " ";
return $out;
}
sub askbool {
my ($text, $default, $star) = @_;
$text = "* $text" if $star;
if ($default eq "true") {
print align("$text [Y/n] ");
} else {
$default = "false";
print align("$text [y/N] ");
}
while (my $l = <STDIN>) {
chomp($l);
if ($default eq "true" && $l =~ /^n$/i) {
return "false";
} elsif ($default eq "false" && $l =~ /^y$/i) {
return "true";
} elsif (!$default && $l eq '') {
return undef;
} else {
return $default;
}
}
}
sub askPass {
my ($text) = @_;
which_bipmkpw();
print("$text ? ");
my $pass = `$bipmkpw`;
chomp($pass);
$pass =~ s/^Password:\s*\n?//si;
chomp($pass);
return $pass;
}
sub which_bipmkpw {
my ($which);
return if ($bipmkpw ne '' && -x "$bipmkpw");
if (-x "/usr/bin/bipmkpw") {
$bipmkpw = '/usr/bin/bipmkpw';
return;
}
$which = `which bipmkpw`;
if ($which ne '' && -x "$which") {
$bipmkpw = $which;
return;
}
while (!$bipmkpw || ! -x "$bipmkpw") {
if ($bipmkpw ne '' && (! -f $bipmkpw || ! -x $bipmkpw)) {
print("No exec permission: $bipmkpw\n");
}
$bipmkpw = askval("Please enter the path to bipmkpw:",
undef, 1);
}
return;
}
sub askval {
my ($text, $default, $skipblank, $star) = @_;
$text .= " ";
$text .= "[$default] " if ($default ne undef);
$text = "* $text" if $star;
print(align("$text"));
while (my $l = <STDIN>) {
chomp($l);
# if ($default eq undef && !$skipblank && $l eq '') {
# my $q = askbool("You've entered a blank value, do you want this field to be unset (if not, it'll be set to the empty string) ?", "true");
# return undef if ($q eq 'true');
# }
return ($l ne '' ? $l : $default);
}
}
sub checkDepends {
my ($n, $v) = @_;
return if (!exists($v->{'depends'}));
my $d = $v->{'depends'};
if (!exists($cf{'global'}->{$d})) {
return "You cannot define `$n' since `$d' isn't defined";
}
if (exists($v->{'depval'}) &&
$cf{'global'}->{$d} ne $v->{'depval'}) {
return "You cannot define `$n' since `$d' isn't set to " .
$v->{'depval'};
}
}
sub loadConfig {
my ($f) = @_;
my ($fh, $data, $hr);
$fh = new IO::File;
$data = '';
$fh->open($f) || return "Unable to open $f";
while (<$fh>) {
chomp();
$data .= $_;
}
$fh->close;
$hr = unserialize($data) || return "Invalid format in $f";
%cf = %{$hr};
$cf{'networks'} = [ values %{$cf{'networks'}} ];
$cf{'users'} = [ values %{$cf{'users'}} ];
sanitizeCompat(\%cf);
foreach (@{$cf{'networks'}}) {
$_->{'server'} = [ values %{$_->{'server'}} ];
}
foreach my $tcu (@{$cf{'users'}}) {
my $backlog_no_timestamp = delete($tcu->{'backlog_no_timestamp'});
if (defined $backlog_no_timestamp) {
grep(/^$backlog_no_timestamp$/, ('false', 'true')) || return "Invalid value for backlog_no_timestamp: '$backlog_no_timestamp'";
$tcu->{'backlog_timestamp'} = $backlog_no_timestamp == 'false' ? 'time' : 'none';
}
$tcu->{'connection'} = [ values %{$tcu->{'connection'}} ];
foreach my $tcc (@{$tcu->{'connection'}}) {
$tcc->{'channel'} = [ values %{$tcc->{'channel'}} ];
}
}
return "Config loaded from $f";
}
sub sanitizeCompat {
my ($d) = @_;
foreach (keys %$d) {
if (ref($d->{$_}) eq 'ARRAY') {
foreach my $d2 (@{$d->{$_}}) {
sanitizeCompat($d2);
}
}
$d->{$optcompat{$_}} = $d->{$_} if (defined $optcompat{$_});
}
}
sub resetConfig {
my $r = askbool("Do you want to reset current loaded configuration options, networks, users... ?", 'false');
$r eq 'false' && return "Reset config aborted";
%cf = ();
-e "$sfile" || return "Configuration cleared";
my $r = askbool("Do you want to delete saved configuration file $sfile too ?", 'false');
if ($r eq 'true') {
unlink($sfile) || return "Unable to remove file $sfile, current config has been cleared";
return "Configuration cleared, saved-configuration file removed";
}
return "Configuration cleared";
}
sub setOptions {
foreach my $n (@{$optorder{'global'}}) {
if ($n eq undef) {
print("\n");
next;
}
my $e = $optdesc{'global'}->{$n};
my $r = checkDepends($n, $e);
if ($r) {
print("$r\n") if ($DEBUG);
$cf{'global'}->{$n} = undef;
next;
}
$cf{'global'}->{$n} = askOpt($e, $cf{'global'}->{$n});
}
$global_done = 1;
pause();
return "Options have been set";
}
sub printOptions {
my $cnt = 1;
foreach my $n (@{$optorder{'global'}}) {
next if (!$n);
my $e = $optdesc{'global'}->{$n};
next if ($e->{'type'} eq 'e' || $e->{'nosave'} eq 1);
next if ($mode eq 'normal' && $e->{'adv'} eq 1);
my $r = checkDepends($n, $e);
if ($r) {
printf('%02d.(%s - unset, missing dependency)'."\n", $cnt, $n);
} elsif (exists($cf{'global'}->{$n})) {
printf('%02d. %s = %s'."\n", $cnt, $n, $cf{'global'}->{$n});
} else {
printf('%02d. %s - unset'."\n", $cnt, $n);
}
$cnt++;
}
pause();
return;
}
sub makeCert {
my ($fh, $c, $o, $ou, $cn);
$fh = new IO::File;
$c = askval("SSL cert country :", undef, 1);
$o = askval("SSL cert organisation :", "Sexy boys");
$ou = askval("SSL cert organisational unit :", "Bip");
$cn = askval("SSL cert common name :", "Bip");
$fh->open("> $tmpcrt");
return "Unable to write to $tmpcrt\n" if (!$fh);
print $fh "HOME = .
[ req ]
distinguished_name = dn
x509_extensions = v3_bip
default_md = sha1
prompt = no
[ dn ]
C=$c
O=$o
OU=$ou
CN=$cn
[ v3_bip ]
subjectKeyIdentifier=hash
authorityKeyIdentifier=keyid:always";
# if (-e $certout) {
# my @t = localtime(time);
# my $ts = sprintf("%04d-%02d-%02d.%02d:%02d:%02d", 1900+$t[5], 1+$t[4], $t[3], $t[2], $t[1], $t[0]);
# rename($certout, "$certout.$ts");
# print "Existing $certout found, renamed to $certout.$ts\n";
# }
`openssl req -new -newkey rsa:4096 -x509 -days 365 -nodes -config "$tmpcrt" -out "$certout" -keyout "$certout"`;
# TODO check command status
`openssl x509 -subject -dates -fingerprint -noout -in "$certout"`;
# TODO check command status
$cert_done = 1;
print "Certificate/key pair has been generated in $certout\n";
unlink("$tmpcrt");
pause();
return "Certificate/key pair has been generated in $certout";
}
sub writeConfig {
my ($f) = @_;
my ($fh, $ts, @t);
$ts = localtime(time);
$fh = new IO::File;
if (!$fh->open('> ' . $f)) {
print("Unable to open $f for writing\n");
return;
}
print $fh "# vim:ft=bip:ts=2\n";
print $fh "# Auto-generated BIP IRC Proxy configuration $ts \n";
print $fh "#\n";
print $fh "### Global options\n";
foreach my $k (keys(%{$cf{'global'}})) {
next if ($cf{'global'}->{$k} eq undef);
next if ($optdesc{'global'}->{$k}->{'nosave'} eq 1);
my $t = $optdesc{'global'}->{$k}->{'type'};
if ($t eq 's') {
print $fh "$k = \"" . $cf{'global'}->{$k} . "\";\n";
} else {
print $fh "$k = " . $cf{'global'}->{$k} . ";\n";
}
}
print $fh "\n";
print $fh "### Networks\n";
foreach my $e (@{$cf{'networks'}}) {
my $out = printBlock("", 'network', $e, 1);
print $fh $out;
}
print $fh "\n";
print $fh "### Users\n";
foreach my $e (@{$cf{'users'}}) {
my $out = printBlock("", 'user', $e, 1);
print $fh $out;
}
print $fh "\n";
$fh->close;
print("Configuration saved in $f\n");
my $u = (exists($cf{'users'}) ? scalar @{$cf{'users'}}
: 0);
my $n = (exists($cf{'networks'}) ? scalar @{$cf{'networks'}}
: 0);
print "You haven't set global options\n" if (!$global_done);
print "$u users defined, $n networks defined\n";
print "The certificate/key pair is in $certout\n"
if ($cert_done eq 1);
print "Configuration has been generated in $CFILE\n";
print "You have to rename all generated files to use them\n";
return;
}
sub storeConfig {
my ($f) = @_;
my ($fh);
$fh = new IO::File;
$fh->open('> ' . $f) || return "Unable to open $f for writing";
print $fh serialize(\%cf);
$fh->close;
return "Configuration stored in $f";
}
sub printBlock {
my ($prefix, $name, $e, $level) = @_;
my $out = '';
fatal("Too much recursion levels ($level)") if ($level ge $maxlevel);
$out .= $prefix . $name . " {\n";
foreach my $k (@{$optorder{$name}}) {
next if ($k eq undef);
next if ($e->{$k} eq undef);
next if ($optdesc{$name}->{$k}->{'nosave'} eq 1);
my $t = $optdesc{$name}->{$k}->{'type'};
if ($t eq 's' || $t eq 'p') {
$out .= $prefix . "\t$k = \"" . $e->{$k} . "\";\n";
} elsif (ref($e->{$k}) eq 'ARRAY') {
foreach my $e2 (@{$e->{$k}}) {
$out .= printBlock($prefix . "\t", $k, $e2, $level+1);
}
} else {
$out .= $prefix . "\t$k = " . $e->{$k} . ";\n";
}
}
$out .= $prefix . "};\n\n";
return $out;
}
sub addEntry {
my ($section, $nopause) = @_;
my ($e, $opts);
$opts = $optdesc{$section};
foreach my $n (@{$optorder{$section}}) {
if ($n eq undef) {
print("\n");
next;
}
my $v = $optdesc{$section}->{$n};
my $r = checkDepends($n, $v);
if ($r) {
$e->{$n} = undef;
print("$r\n") if ($DEBUG);
next;
}
if ($v->{'type'} eq 'e') {
my $first = 1;
do {
if ($v->{'optional'} eq 1 || !$first) {
my $a = askbool("Do you want to add a new $n ?", 'true');
last if ($a eq 'false');
}
print("\nAdding a new $n :\n");
my $e2 = addEntry($n, 1);
if (ref($e->{$n}) eq 'ARRAY') {
push(@{$e->{$n}}, $e2);
} else {
$e->{$n} = [ $e2 ];
}
$first = 0;
} while (1);
} else {
$e->{$n} = askOpt($v);
}
}
pause() if (!$nopause);
return $e;
}
sub pause {
my ($txt) = @_;
$txt = "Press any key to continue" if (!$txt);
print("\n" . $txt . "\n");
<STDIN>;
}
sub printMenu {
my ($mhead, $mopts, $mfoot, $mask) = @_;
push(@{$mhead}, undef);
if ($mode eq 'normal') {
push(@{$mhead},
"WARNING: non-advanced mode, some 'expert' " .
"options'll be hidden !");
} else {
push(@{$mhead}, undef);
}
push(@{$mhead}, undef);
print($clear_string);
print("###########################################################" .
"###################\n# ");
print(join("\n# ", @{$mhead}));
print("\n");
print("\n");
foreach my $n (sort {$a <=> $b} keys(%{$mopts})) {
if ($mopts->{$n} eq undef) {
print("\n");
next;
}
printf(' %2d. %s%s', $n, $mopts->{$n}, "\n");
}
print("\n");
print(join("\n", @{$mfoot}));
print("\n");
print("\n");
return askval($mask, undef, 1);
}
sub printUsers {
my ($txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $num, $warn, $act, $out);
$mhead = [
"Bip's user list",
];
$mfoot = [ $txt ];
$mask = "Enter id of the user to edit ?";
$mopts = { 0 => 'Return to main menu'};
$mopts->{"0.5"} = undef;
$num = 1;
foreach my $n (@{$cf{'users'}}) {
$mopts->{$num} = $n->{'name'} . ': ' .
(scalar @{$n->{'connection'}}) . ' connections.';
$num++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act =~ /^\d+$/) {
my $n = $cf{'users'};
my $c = $num-1;
if (($num-$act) le 0) {
$out = "There are only $c users";
} else {
$out = printEditUser($act-1);
}
} else {
$out = "Invalid user ID";
}
printUsers($out);
}
sub printNetworks {
my ($txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $num, $warn, $act, $out);
$mhead = [
"Bip's network list",
];
$mfoot = [ $txt ];
$mask = "Enter ID of the network to edit ?";
$mopts = { 0 => 'Return to main menu'};
$mopts->{"0.5"} = undef;
$num = 1;
foreach my $n (@{$cf{'networks'}}) {
$mopts->{$num} = $n->{'name'} . ': ' . (scalar @{$n->{'server'}})
. ' servers, SSL ' . ($n->{'ssl'} eq 'true' ?
'enabled' : 'disabled');
$num++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act =~ /^\d+$/) {
my $n = $cf{'networks'};
my $c = $num-1;
if (($num-$act) le 0) {
$out = "There are only $c networks";
} else {
$out = printEditNetwork($act-1);
}
} else {
$out = "Invalid network ID";
}
printNetworks($out);
}
sub addChannel {
my ($uid, $cid) = @_;
my ($cnt, @o, $n, $c, $name);
return "Invalid user ID $uid"
if ((scalar @{$cf{'users'}}) le $uid);
$n = $cf{'users'}[$uid];
return "Invalid connection ID $cid"
if ((scalar @{$n->{'connection'}}) le $cid);
my $e = addEntry('channel');
if ($e) {
push(@{$n->{'connection'}[$cid]->{'channel'}}, $e);
return "Channel " . $e->{'name'} . " added";
} else {
return "Channel add failed";
}
}
sub addServer {
my ($id) = @_;
return "Invalid network ID $id"
if ((scalar @{$cf{'networks'}}) le $id);
my $e = addEntry('server');
if ($e) {
push(@{$cf{'networks'}[$id]->{'server'}}, $e);
return "Server " . $e->{'host'} . " added";
} else {
return "Server add failed";
}
}
sub addConnection {
my ($id) = @_;
return "Invalid user ID $id"
if ((scalar @{$cf{'users'}}) le $id);
my $e = addEntry('connection');
if ($e) {
push(@{$cf{'users'}[$id]->{'connection'}}, $e);
return "Connection " . $e->{'name'} . " added";
} else {
return "Connection add failed";
}
}
sub deleteServer {
my ($net, $sid) = @_;
my ($sname, $ss, $cnt, @o);
return "Invalid network ID $net"
if ((scalar @{$cf{'networks'}}) le $net);
$ss = $cf{'networks'}[$net]->{'server'};
return "Invalid server ID $sid" if ((scalar @{$ss}) lt $sid);
@o = ();
$cnt = 0;
foreach my $s (@{$ss}) {
if ($sid ne $cnt) {
push(@o, $s);
} else {
$sname = $s->{'host'};
}
$cnt++;
}
$cf{'networks'}[$net]->{'server'} = [ @o ];
return "Server $sname removed";
}
sub delUser {
my ($id) = @_;
my ($cnt, @o, $name);
return "Invalid user ID $id"
if ((scalar @{$cf{'users'}}) le $id);
$cnt = 0;
@o = ();
foreach my $n (@{$cf{'users'}}) {
if ($id ne $cnt) {
push(@o, $n);
} else {
$name = $n->{'name'};
}
$cnt++;
}
$cf{'users'} = [ @o ];
return "User $name removed";
}
sub delNetwork {
my ($id) = @_;
my ($cnt, @o, $name);
return "Invalid network ID $id"
if ((scalar @{$cf{'networks'}}) le $id);
$cnt = 0;
@o = ();
foreach my $n (@{$cf{'networks'}}) {
if ($id ne $cnt) {
push(@o, $n);
} else {
$name = $n->{'name'};
}
$cnt++;
}
$cf{'networks'} = [ @o ];
return "Network $name removed";
}
sub deleteConn {
my ($uid, $cid) = @_;
my ($cnt, @o, $n, $name);
return "Invalid user ID $uid"
if ((scalar @{$cf{'users'}}) le $uid);
$n = $cf{'users'}[$uid];
return "Invalid connection ID $cid"
if ((scalar @{$n->{'connection'}}) le $cid);
$cnt = 0;
@o = ();
foreach my $n (@{$n->{'connection'}}) {
if ($cid ne $cnt) {
push(@o, $n);
} else {
$name = $n->{'name'};
}
$cnt++;
}
$cf{'users'}[$uid]->{'connection'} = [ @o ];
return "Connection $name removed";
}
sub deleteChannel {
my ($uid, $cid, $chid) = @_;
my ($cnt, @o, $n, $c, $name);
return "Invalid user ID $uid"
if ((scalar @{$cf{'users'}}) le $uid);
$n = $cf{'users'}[$uid];
return "Invalid connection ID $cid"
if ((scalar @{$n->{'connection'}}) le $cid);
$c = $n->{'connection'}[$cid];
return "Invalid channel ID $chid"
if ((scalar @{$c->{'channel'}}) le $chid);
$cnt = 0;
@o = ();
foreach my $n (@{$c->{'channel'}}) {
if ($chid ne $cnt) {
push(@o, $n);
} else {
$name = $n->{'name'};
}
$cnt++;
}
$cf{'users'}[$uid]->{'connection'}[$cid]->{'channel'} = [ @o ];
return "Channel $name removed";
}
sub printEditConnOptions {
my ($num, $num2, $txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out);
my ($n, $c, $name, $sub, $cnt);
return "Invalid user ID $num"
if ((scalar @{$cf{'users'}}) le $num);
$n = $cf{'users'}[$num];
return "Invalid connection ID $num2"
if ((scalar @{$n->{'connection'}}) le $num2);
$c = $n->{'connection'}[$num2];
$name = $c->{'name'};
$mhead = [
"Edit connection options $name/" . $n->{'name'},
];
$mfoot = [ $txt ];
$mopts = { 0 => 'Return to connection ' . $name,
"0.5" => undef,
};
$cnt = 1;
my %oo = ();
foreach my $s (@{$optorder{'connection'}}) {
next if (!$s);
next if ($optdesc{'connection'}->{$s}->{'type'} eq 'e');
next if ($optdesc{'connection'}->{$s}->{'nosave'} eq 1);
next if ($mode eq 'normal' &&
$optdesc{'connection'}->{$s}->{'adv'} eq 1);
$mopts->{$cnt} = "Change $s: ";
$mopts->{$cnt} .= $c->{$s} if (defined $c->{$s});
$oo{$cnt} = $s;
$cnt++;
}
$act = int(printMenu($mhead, $mopts, $mfoot, $mask));
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act =~ /^\d+$/) {
my $c = $cnt-1;
if (($cnt-$act) le 0) {
$out = "There are only $c options";
} else {
my $on = $oo{$act};
$cf{'users'}[$num]->{'connection'}[$num2]->{$on} =
askOpt($optdesc{'connection'}->{$on},
$cf{'users'}[$num]->{'connection'}[$num2]->{$on});
$out = "Option $on set";
pause();
}
} else {
$out = "Invalid option ID";
}
printEditConnOptions($num, $num2, $out);
}
sub printEditConnection {
my ($num, $num2, $txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out);
my ($n, $name, $sub, $cnt, $c);
return "Invalid user ID $num"
if ((scalar @{$cf{'users'}}) le $num);
$n = $cf{'users'}[$num];
return "Invalid connection ID $num2"
if ((scalar @{$n->{'connection'}}) le $num2);
$c = $n->{'connection'}[$num2];
$name = $c->{'name'};
$sub = $c->{'channel'};
$mhead = [
"Edit connection $name/" . $n->{'name'},
];
$mfoot = [ $txt ];
$mask = "What do you want to do ?";
$mopts = { 0 => 'Return to user ' . $n->{'name'},
1 => 'Add a channel',
2 => 'Edit options',
3 => 'Remove this connection',
"3.5" => undef,
};
$cnt = 4;
foreach my $s (@{$sub}) {
$mopts->{$cnt} = "Delete channel " . $s->{'name'};
$mopts->{$cnt} .= '/' . $s->{'key'} if (defined $s->{'key'} &&
$s->{'key'} ne '');
$cnt++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act eq 1) {
$out = addChannel($num, $num2);
} elsif ($act eq 2) {
return printEditConnOptions($num, $num2);
} elsif ($act eq 3) {
return deleteConn($num, $num2);
} elsif ($act =~ /^\d+$/) {
my $c = $cnt-4;
if (($cnt-$act) le 0) {
$out = "This connection has only $c channels";
} else {
$out = deleteChannel($num, $num2, $act-4);
}
} else {
$out = "Invalid channel ID";
}
printEditConnection($num, $num2, $out);
}
sub printEditUserOptions {
my ($num, $txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out);
my ($n, $name, $sub, $cnt);
return "Invalid user ID $num"
if ((scalar @{$cf{'users'}}) le $num);
$n = $cf{'users'}[$num];
$name = $n->{'name'};
$mhead = [
"Edit user $name options",
];
$mfoot = [ $txt ];
$mask = "What do you want to do ?";
$mopts = { 0 => 'Return to user ' . $name,
"0.5" => undef,
};
$cnt = 1;
my %oo = ();
foreach my $s (@{$optorder{'user'}}) {
next if (!$s);
next if ($optdesc{'user'}->{$s}->{'type'} eq 'e');
next if ($optdesc{'user'}->{$s}->{'nosave'} eq 1);
next if ($mode eq 'normal' &&
$optdesc{'user'}->{$s}->{'adv'} eq 1);
$mopts->{$cnt} = "Change $s: ";
$mopts->{$cnt} .= $n->{$s} if (defined $n->{$s});
$oo{$cnt} = $s;
$cnt++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act =~ /^\d+$/) {
my $c = $cnt-1;
if (($cnt-$act) le 0) {
$out = "There are only $c options";
} else {
my $on = $oo{$act};
$cf{'users'}[$num]->{$on} = askOpt(
$optdesc{'user'}->{$on},
$cf{'users'}[$num]->{$on});
$out = "Option $on set";
pause();
}
} else {
$out = "Invalid option ID";
}
printEditUserOptions($num, $out);
}
sub printEditUser {
my ($num, $txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out);
my ($n, $name, $sub, $cnt);
return "Invalid user ID $num"
if ((scalar @{$cf{'users'}}) le $num);
$n = $cf{'users'}[$num];
$name = $n->{'name'};
$sub = $n->{'connection'};
$mhead = [
"Edit user $name",
];
$mfoot = [ $txt ];
$mask = "What do you want to do ?";
$mopts = { 0 => 'Return to users list',
1 => 'Add a connection',
2 => 'Edit options',
3 => 'Remove this user',
"3.5" => undef,
};
$cnt = 4;
foreach my $s (@{$sub}) {
$mopts->{$cnt} = "Edit connection " . $s->{'name'};
$cnt++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act eq 1) {
$out = addConnection($num);
} elsif ($act eq 2) {
return printEditUserOptions($num);
} elsif ($act eq 3) {
return delUser($num);
} elsif ($act =~ /^\d+$/) {
my $c = $cnt-4;
if (($cnt-$act) le 0) {
$out = "This user has only $c connections";
} else {
$out = printEditConnection($num, $act-4)
}
} else {
$out = "Invalid connection ID";
}
printEditUser($num, $out);
}
sub printEditNetwork {
my ($num, $txt) = @_;
my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out);
my ($n, $name, $sub, $cnt);
return "Invalid network ID $num"
if ((scalar @{$cf{'networks'}}) le $num);
$n = $cf{'networks'}[$num];
$name = $n->{'name'};
$sub = $n->{'server'};
$mhead = [
"Edit network $name",
];
$mfoot = [ $txt ];
$mask = "What do you want to do ?";
$mopts = { 0 => 'Return to networks list',
1 => 'Add a server',
2 => 'Remove this network',
"2.5" => undef,
};
$cnt = 3;
foreach my $s (@{$sub}) {
$mopts->{$cnt} = "Delete server: " . $s->{'host'} . '/' .
$s->{'port'};
$cnt++;
}
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
return;
} elsif ($act eq 1) {
$out = addServer($num);
} elsif ($act eq 2) {
return delNetwork($num);
} elsif ($act =~ /^\d+$/) {
my $c = $cnt-3;
if (($cnt-$act) le 0) {
$out = "This network has only $c servers";
} else {
$out = deleteServer($num, $act-3)
}
} else {
$out = "Invalid server ID";
}
printEditNetwork($num, $out);
}
sub main_menu {
my ($txt) = @_;
my ($act, $out, $warn, $mopts, $mhead, $mfoot);
my ($mhead, $mask);
$mopts = {
1 => 'Set global options',
2 => 'Add a new network',
3 => 'Add a new user',
3.5 => undef,
4 => 'View global options',
5 => 'View/Edit/Delete networks',
6 => 'View/Edit/Delete users',
7 => 'Generate a server certificate/key pair',
8 => 'Switch to ' . invMode($mode) . ' mode',
8.5 => undef,
10 => 'Exit: store, write configuration and exit',
11 => 'Exit without saving',
12 => 'Store configuration for later use',
12.5 => undef,
20 => 'Reset config options',
21 => 'Load stored config',
22 => 'Parse and load current config (todo)',
};
$mhead = [
"Welcome to bip configuration program.",
"This script will help you build a configuration file",
];
$mfoot = [ $txt ];
$mask = "What do you want to do ?";
$act = printMenu($mhead, $mopts, $mfoot, $mask);
print($clear_string);
if ($act eq 0) {
} elsif ($act eq 1) {
$out = setOptions();
} elsif ($act eq 2) {
$out = addEntry('network');
if ($out) {
push(@{$cf{'networks'}}, $out);
$out = "New network added";
} else {
$out = "Network add failed";
}
} elsif ($act eq 3) {
$out = addEntry('user');
if ($out) {
push(@{$cf{'users'}}, $out);
$out = "New user added";
} else {
$out = "User add failed";
}
} elsif ($act eq 4) {
$out = printOptions();
} elsif ($act eq 5) {
$out = printNetworks();
} elsif ($act eq 6) {
$out = printUsers();
} elsif ($act eq 7) {
$out = makeCert();
} elsif ($act eq 8) {
$mode = invMode();
$out = "Ok, configuration mode set to $mode";
} elsif ($act eq 10) {
print Dumper(\%cf) if ($DEBUG);
$out = storeConfig($sfile);
print ("$out\n") if ($out);
writeConfig($CFILE);
exit(0);
} elsif ($act eq 11) {
print Dumper(\%cf) if ($DEBUG);
exit(0);
} elsif ($act eq 12) {
$out = storeConfig($sfile);
print ("$out\n") if ($out);
pause();
} elsif ($act eq 20) {
$out = resetConfig();
} elsif ($act eq 21) {
$out = loadConfig($sfile);
}
main_menu($out);
}
sub invMode {
return ($mode eq 'advanced' ? 'normal' : 'advanced');
}
if (! -e $bipdir) {
mkdir($bipdir) || fatal("Unable to create bip's dir `$bipdir'");
} elsif (! -d $bipdir) {
fatal("Bip's dir `$bipdir' already exists and is not a directory");
} elsif (! -w $bipdir) {
fatal("Bip's dir `$bipdir' already exists and is not writable");
}
main_menu();
#sets config backlog
#different user/nick/real ?
####################
# Serialize code, from Scott Hurring's serialize serialize module
# see http://hurring.com/ for more
# TODO maybe use Storable ?
sub serialize {
my ($value) = @_;
return serialize_value($value);
}
sub serialize_key {
my ($value) = @_;
my $s;
# Serialize this as an integer
if ($value =~ /^\d+$/) {
# Kevin Haidl - PHP can only handle (((2**32)/2) - 1)
# before value must be serialized as a double
if (abs($value) > ((2**32)/2-1)) {
$s = "d:$value;";
}
else {
$s = "i:$value;";
}
}
# Serialize everything else as a string
else {
my $vlen = length($value);
$s = "s:$vlen:\"$value\";";
}
return $s;
}
sub serialize_value {
my ($value) = @_;
my $s;
$value = defined($value) ? $value : '';
# This is a hash ref
if ( ref($value) =~ /hash/i) {
#The data in the hashref
my $num = keys(%{$value});
$s .= "a:$num:{";
foreach my $k ( keys(%$value) ) {
$s .= serialize_key( $k );
$s .= serialize_value( $$value{$k} );
}
$s .= "}";
}
# This is an array ref
elsif ( ref($value) =~ /array/i) {
#The data in the arrayref
my $num = @{$value};
$s .= "a:$num:{";
for (my $k=0; $k < @$value; $k++ ) {
$s .= serialize_key( $k );
$s .= serialize_value( $$value[$k] );
}
$s .= "}";
}
# This is a double
# Thanks to Konrad Stepien <konrad@interdata.net.pl>
# for pointing out correct handling of negative numbers.
elsif ($value =~ /^\-?(\d+)\.(\d+)$/) {
$s = "d:$value;";
}
# This is an integer
elsif ($value =~ /^\-?\d+$/) {
# Kevin Haidl - PHP can only handle (((2**32)/2) - 1)
# before value must be serialized as a double
if (abs($value) > ((2**32)/2-1)) {
$s = "d:$value;";
}
else {
$s = "i:$value;";
}
}
# This is a NULL value
#
# Only values of "\0" will be serialized as NULL
# Empty strings are not NULL, they are simply empty strings.
# @note Differs from v0.7 where string "NULL" was serialized as "N;"
elsif ($value eq "\0") {
$s = "N;";
}
# Anything else is interpreted as a string
else {
my $vlen = length($value);
$s = "s:$vlen:\"$value\";";
}
return $s;
}
sub unserialize {
my ($string) = @_;
return unserialize_value($string);
}
sub unserialize_value {
my ($value) = @_;
# Thanks to Ron Grabowski [ronnie (at) catlover.com] for suggesting
# the need for single-value unserialize code
# This is an array
if ($value =~ /^a:(\d+):\{(.*)\}$/) {
serialize_dbg("Unserializing array");
my @chars = split(//, $2);
# Add one extra char at the end so that the loop has one extra
# cycle to hit the 'set' state and set the final value
# Otherwise it'll terminate before setting the last value
push(@chars, ';');
return unserialize_sub({}, $1*2, \@chars);
}
# This is a single string
elsif ($value =~ /^s:(\d+):(.*);$/) {
serialize_dbg("Unserializing single string ($value)");
#$string =~ /^s:(\d+):/;
return $2;
#return substr($string, length($1) + 4, $1);
}
# This is a single integer or double value
elsif ($value =~ /^(i|d):(\-?\d+\.?\d+?);$/) {
serialize_dbg("Unserializing integer or double ($value)");
return $2
#substr($string, 2) + 0;
}
# This is a NULL value
# Thanks to Julian Jares [jjares at uolsinectis.com.ar]
elsif ($value == /^N;$/i) {
serialize_dbg("Unserializing NULL value ($value)");
return "\0";
}
# This is a boolean
# Thanks to Charles M Hall (cmhall at hawaii dot edu)
elsif ($value =~/^b:(\d+);$/) {
serialize_dbg("Unserializing boolean value ($value)");
return $1;
}
# Invalid data
else {
serialize_dbg("Unserializing BAD DATA!\n($value)");
die("Trying to unserialize bad data!");
return '';
}
}
sub unserialize_sub {
my ($hashref, $keys, $chars) = @_;
my ($temp, $keyname, $skip, $strlen);
my $mode = 'normal'; #default mode
serialize_dbg("> unserialize: $hashref, $keys, $chars");
# Loop through the data char-by-char, eating them as we go...
while ( defined(my $c = shift @{$chars}) )
{
serialize_dbg("\twhile [$mode] = $c (skip=$skip)");
# Processing a serialized string
# Format: s:length:"data"
if ($mode eq 'string') {
$skip = 1; #how many chars should 'readstring' skip?
#skip initial quote " at the beginning.
#find out how many chars need to be read
if ($c =~ /\d+/) {
#get the length of string
$strlen = $strlen . $c;
}
#if we already have a length, and see ':', we know that
#the actual string is coming next (see format above)
if (($strlen =~ /\d+/) && ($c eq ':')) {
serialize_dbg("[string] length = $strlen");
$mode = 'readstring';
}
}
# Read $strlen number of characters into $temp
elsif ($mode eq 'readstring') {
next if ($skip && ($skip-- > 0));
$mode = 'set', next if (!$strlen--);
$temp .= $c;
}
# Process a serialized integer
# Format: i:data
elsif ($mode eq 'integer') {
next if ($c eq ':');
$mode = 'set', next if ($c eq ';');
# Grab the digits
# Thanks to Konrad Stepien <konrad@interdata.net.pl>
# for pointing out correct handling of negative numbers.
if ($c =~ /\-|\d+/) {
if ($c eq '-') {
$temp .= $c unless $temp;
} else {
$temp .= $c;
}
}
}
# Process a serialized double
# Format: d:data
elsif ($mode eq 'double') {
next if ($c eq ':');
$mode = 'set', next if ($c eq ';');
# Grab the digits
# Thanks to Konrad Stepien <konrad@interdata.net.pl>
# for pointing out correct handling of negative numbers.
if ($c =~ /\-|\d+|\./) {
if ($c eq '-') {
$temp .= $c unless $temp;
} else {
$temp .= $c;
}
}
}
# Process a serialized NULL value
# Format: N
# Thanks to Julian Jares [jjares at uolsinectis.com.ar]
elsif ($mode eq 'null') {
# Set $temp to something perl will recognize as null "\0"
# Don't unserialize as an empty string, becuase PHP
# serializes empty srings as empty strings, not null.
$temp = "\0";
$mode = 'set', next;
}
# Process an array
# Format: a:num_of_keys:{...}
elsif ($mode eq 'array') {
# Start of array definition, start processing it
if ($c eq '{') {
$temp = unserialize_sub( $$hashref{$keyname}, ($temp*2), $chars );
# If temp is an empty array, change to {}
# Thanks to Charles M Hall (cmhall at hawaii dot edu)
if(!defined($temp) || $temp eq "") {
$temp = {};
}
$mode = 'set', next;
}
# Reading in the number of keys in this array
elsif ($c =~ /\d+/) {
$temp = $temp . $c;
serialize_dbg("array_length = $temp ($c)");
}
}
# Do something with the $temp variable we read in.
# It's either holding data for a key or a value.
elsif ($mode eq 'set') {
# The keyname has already been set, so that means
# $temp holds the value
if (defined($keyname)) {
serialize_dbg("set [$keyname]=$temp");
$$hashref{$keyname} = $temp;
# blank out keyname
undef $keyname;
}
# $temp holds a keyname
else {
serialize_dbg("set KEY=$temp");
$keyname = $temp;
}
undef $temp;
$mode = 'normal'; # dont eat any chars
}
# Figure out what the upcoming value is and set the state for it.
if ($mode eq 'normal') {
# Blank out temp vars used by previous state.
$strlen = $temp = '';
if (!$keys) {
serialize_dbg("return normally, finished processing keys");
return $hashref;
}
# Upcoming information is integer
if ($c eq 'i') {
$mode = 'integer';
$keys--;
}
# Upcoming information is a bool,
# process the same as an integer
if ($c eq 'b') {
$mode = 'integer';
$keys--;
}
# Upcoming information is a double
if ($c eq 'd') {
$mode = 'double';
$keys--;
}
# Upcoming information is string
if ($c eq 's') {
$mode = 'string';
$keys--;
}
# Upcoming information is array/hash
if ($c eq 'a') {
$mode = 'array';
$keys--;
}
# Upcoming information is a null value
if ($c eq 'N') {
$mode = 'null';
$keys--;
}
}
} #while there are chars to process
# You should never hit this point.
# If you do hit this, it means that the code was expecting more
# characters than it was given.
# Perhaps your data was unexpectedly truncated or mutilated?
serialize_dbg("> unserialize_sub ran out of chars when it was expecting more.");
die("unserialize_sub() ran out of characters when it was expecting more.");
return 0;
}
sub serialize_dbg {
my ($string) = @_;
if ($SERIALIZE_DBG) {
print $string ."\n";
}
}
View Git Blame Copy Permalink