#!/usr/bin/perl
# unpack
# prepend to .pk files to produce self extracting packages
print "extracting\n";
$ok=1;
  while ($ok == 1)
  { $line = <DATA>;
    if ($line eq '' || $line = $null) { $ok = 0; }
    $line =~ s/\n//;
    ($type, $name, $path) = split(/:/,$line, 3);

    if ($type eq "link")
    { symlink ($path, $name);
    }
    elsif ($type eq "dir")
    { mkdir ($name, 0755);
      chdir $name;
    }
    elsif ($type eq "file")
    { open (file, ">$name");
      while (($line = <DATA>) !~ /\\end/)
      { $line =~ s/\\1/\\/;
	print file $line;
      }
      close (thisfile);
      $path && chmod ($path, $name);
    }
    elsif ($type eq "edir")
    { chdir '..';
    }
    # if $type eq * 
  } # while <DATA>

  __END__
file:lsmud:100755
#!/usr/bin/perl
# lsmud
# lsmud v0.95

use POSIX;
use IO::Select;
$HOME = $ENV{'PWD'};

$admin='hanelyp@calweb.com';

$SIG{'SIGPIPE'} = sub{&logout; die};

$n = "\1r\1n";

END
{ &logout; }

#############
# variables #
#############

# $pname	characters name
# stats		file handle accessing stats


sub incoming_msg
{ if ($msg = <MSG>)
  { #print;
    @msg = split(' ',$msg,2);
    if ($msg[0] eq 'die')
    { $| = 1;
      $jnk = <>;
      $ppid = getppid();
      kill ($ppid);
      die ("you have been closed by admin $msg[1]");
    }
    else
    { print "$msg$n";}
    1;
  } 
}

sub incoming_command
{ seek (selff, 0, 0);
  %mystats = read_stats(*selff);

# check for damage
  ($b,$d) = split ('-',$mystats{'con'});
  if ($d<$b)
  { $d++;
    $mystats{'con'} = "$b-$d";
    seek (selff, 0, 0);    
    &write_stats(*selff, \1%mystats);
  }
  if ($d<1)
  { print "Rest in peace$n$n$n";
    exit;
  }
 $c = <>;
# print $c;
 if ($c eq "\1x7f") {chop ($cl)}
 else {$cl .= $c}

 ($cl =~ /\1r/) || return;
 # rip out any control chars
 $cl =~ s/[^\1w ]//g;

 if($cl) 
 {
  ($cmd, $p1, $p2, $p3) = split (/\1s/,$cl,4);

  @cl = ($p1,$p2,$p3);
# valid command?
  ($cmd1, $param) = &resolve_cmd($cmd, $p1);
  if ($cmd1)
  { print $n;
    if ($param)
    { unshift @cl, $param; }
    eval (&$cmd1 (@cl) );
  }
  else
  { print ("I can't $cl$n");
  }
  if ($cl) {print ">"}
  $cl = '';
 } # check for input
}
# dmcmd.pl
# player commands for dirmud V 0.9

# command aliases, article detection
%cmd_alias = ("get"=>\1&get, "take"=>\1&get,
	"drop"=>\1&drop, "throw"=>\1&drop,
	"give"=>\1&give,
	"look"=>\1&look, "read"=>\1&look,
	"examine"=>\1&examine,
	"inventory"=>\1&inventory,
	"say"=>\1&say,
	"attack"=>\1&attack,
	"wear"=>\1&wear,
	"wield"=>\1&wield,
	"go"=>\1&go, "goto"=>\1&go, "move"=>\1&go,
	"exit"=>\1&exit,
	"help"=>\1&help, "?"=>\1&help,
	"quit"=>\1&quit, "logout"=>\1&quit);

############
# commands #
############

sub get
{ ($i) = @_;
#  $ret, $whr;
#  local *what;
  { ($i,$whr) = &resolve_obj($i, '../');
    $ret = &move ($i, '../', './');
    case:
    { (($ret==0) && ( print ("$i gotten$n"), last case ));
      (($ret==1) && ( print ("$i is too big for you to get$n"), last case));
      (($ret==2) && ( print ("what $i?$n"), last case));
      print ("internal error, get$n");
    }
  } # each object
}

######################

sub drop
{ my @obj = @_;
#  my $i, $whr;
#  foreach $i (@obj)
  $i = $obj[0];
  { ($i, $whr) = &resolve_obj($i, './'); 
    $ret = &move ($i, './', '../');
    case:
    { (($ret==0) && ( print ("$i dropped$n"), last case));
      (($ret==1) && ( print ("looks like a Wizzard has been at work$n",
		"$i can't be droped$n"), last case));
      (($ret==2) && ( print ("what $i?$n"), last case));
      print ("internal error, drop$n");
    }
  }
# each object
}

######################

sub give
{ my ($what, $who, $jnk) = @_;
  my $whr;
  ($what,$whr) = &resolve_obj($what, './');
  ($who,$whr) =  &resolve_obj($who, '../');
  $ret = move ($what, './', '../'.$who.'/' );
  case:
  { (($ret==0) && ( print ("Most generous$n"), last case));
    (($ret==1) && ( print ("$who can't carry $what$n"), last case));
    (($ret==2) && ( print ("you have no $what to give$n"), last case));
    (($ret==3) && ( print ("$who is not available$n"), last case));
    print ("internal error, give$n");
  }
}

######################

sub look
# read and display first line of obj/.stst
{ my ($what, $recurse) = @_;
#  local *stats, *dir;
#  my $where, $path;
  $whatwhere = "";
# look in surroundings?
  if (!($what))
  { if (open (STS, '<../.stats'))
    { %stats = &read_stats(*STS);
      close STS;
      print $stats{'disc'}, "$n";
    } else
    { print "no stats $n"; }
# list surroundings
    opendir (DR,'../');
    while ($dir = readdir(DR) )
    { if ($dir !~ /^\1./ )
      { print ($dir, "$n");
      } 
    }
    closedir (DR);
  }
# try object
  elsif ( ($w, $where) = &resolve_obj($what, './', '../') )
  { $path = "$where$w/.stats";
    print "$w$n";
    if (open (STS, $path))
    { %stats = &read_stats(*STS);
      close STS;
      print $stats{'disc'}, "$n";
    }
    else
    { print "what can I say, $w$n"; }
  }
# error...
  else
  { print ("what $what$n");
    exit (0);
  }
}

######################

sub examine
{ my ($what, $jnk) = @_;
#  local *stats;
#  my $where;
  if ( ($what, $where) = &resolve_obj($what, './', '../') )
  { open (STS, "$where$what/.stats");
    %stats = &read_stats(*STS);
    close STS;
    print $stats{'disc'}, "$n";
    print $stats{'moredisc'}, "$n";
  }
# error...
  else
  { print ("$what is not in your posession$n");
    exit (0);
  }
}

######################

sub inventory
{ #my @obj, $obj;
#  local *direc;
  opendir (DRC, '.');
  $objcnt = 0;
  @obj = grep (!/^\1./, readdir(DRC) );
  foreach $obj (@obj)
  { print $obj, "$n";
    $objcnt++;
  }
  closedir (DRC);
  if ($objcnt ==0)
  { print "No items$n";
  }
}

######################
sub say
{ my ($who, $msg1, $msg2) = @_;
# global or local speech?
  if (($who, $whr) = &resolve_obj($who, '../') )
  { &message ("../$who" , "$pname: $msg1 $msg2$n");
    print $msg1,' ', $msg2;
  }
  else
# must be global
  { &global_message ('../' , "$pname: $who $msg1 $msg2$n");
    print $who,' ',$msg1,' ',$msg2;
  }
}

######################

sub attack
{ ($targ) = @_;
  # read attack rating from char stats
  ($a) = split ('\1+', $mystats{'attl'});
  # read armor rating, subtract from attack
  $t = &lock(">+$targ");
  %s = &read_stats($t);
  $a -= $s{'ac'};
  # update target hits
  if ($a >0)
  { ($b, $d) = split('-',$s{'con'});
    $d += $a;
    $s{'con'} = "$b-$d";
    &write_stats($t, \1%s);
    &global_message ('../' , "$pname hits $targ for $a$n");
  }
}

######################

sub wear
{ # read stats from armor
  # update char stats
}

######################

sub wield
{ # read stats from weapon
  # update char stats
}

######################

sub go
{ my ($where, @jnk) = @_;
#  local *file;
  ($w, $whr) = &resolve_obj($where, '../');
# try going and see...
  $ret = &move($ucpname, '../', "../$w/");
  case:
  { (($ret==0) && ( &look(), last case));
    (($ret==1) && ( print ("$where is not a place you can go.$n"), last case));
    (($ret==3) && ( print ("Where is $where?$n"), last case));
    (($ret==5) && ( print "$where is locked$n", last case) );
    print "internal error go$n";
  }
}

######################

sub exit
{ local *stats;
  if (!(-f '../.top'))
  { &move ($ucpname, '../', '../../')
    &look();
  }
  else
  { open (STS, '../.top');
    %stats = &read_stats (*STS);
    close STS;
    print ($stats{"disc"}, "$n");
  }
}

######################

sub help
{ open (HLP, "$HOME/help");
  print <HLP>;
  close (HLP);
}

######################

sub quit
{}

#!/usr/bin/perl
# dmlib.pl
# library of common routines for dirmud V 0.95;

############################################

sub lock
{ my ($obj) = @_;
#  local (*file);
  if (open (F, $obj) )
  { flock (F, 2);
    return (*F);
  }
  0;
}

######################

sub unlock
{ local ($O) = @_;
  flock (O, 8);
  close (O);
}

######################
sub read_stats
{ local ($lock) = @_;
#  local %stats, $stt, $stval, $stline;
  seek ($lock, 0,0); 
  while ($stline = <$lock>)
  { ($stt, $stval) = split (/,/,$stline, 2);
    $stats{$stt} = $stval;
  }
  return %stats;
}

######################

sub write_stats
{ local ($lck, $stats) = @_;
  seek ($lck, 0,0);
  foreach $stat (keys(%$stats))
  { $value = $$stats{$stat};
    if (($stat) && (defined ($value)))
    { print $lck "$stat, $value\1n";}
  }
}

######################

sub message
{ my ($who, $msg) = @_;
# fork for message delivery  
  if (!fork() )
  { $xmit = 1;
    if (open(M, ">>$who/.msg") )
    { print (M $msg);
      close (M);
    }
    exit;
  }
}

sub global_message
{ my ($where, $msg) = @_;
  opendir (L, $where);
  while ($who = readdir(L))
  { if ($who !~ /^./)
    { &message("../$who", $msg, 1);}
  }
  closedir(L);
}

##########################

sub resolve_cmd
{ my ($cmd, $param1) = @_;
#  my $cmdr, $p1r, $dir;

# object in scope with "use" ?
#  ($cmdr, $dir) = &resolve_obj($cmd, './', '../');
#  if (-x $dir.$cmdr."/.use")
#  { return (\1&runit, "$dir$cmdr/.use") ;}

# method of $param1 ?
  ($p1r, $dir) = &resolve_obj($param1, './', '../');
  ($c, $dir) = &resolve_obj(".$cmd", "$dir$p1r/");
  if (-x $dir.$c)
  { return (\1&runit, $dir.$c) ;}

# a command in local area, special to char?
  ($c, $dir) = &resolve_obj('.'.$cmd, './', '../');
  if (-x $dir.$c)
  { return (\1&runit, $dir.$c ); }

# standard command?
  if ($c = $cmd_alias{$cmd} )
  { return $c; }

# a place (to go)?
#  ($p1r, $dir) = &resolve_obj($cmd, '../');
#  if ((-d $dir.$p1r) || (-l $dir.$p1r))
#  { return (\1&go, $p1r) ;}
# not a valid command
  0;
}

#################################################
sub runit
{ my ($cmd,$p1,$p2,$p3) = @_;
#  local *method;
  open (M, "$cmd $p1 $p2 $p3 |");
  while (<M>) {print ;}
  close M;
}

################################
%default_stat =("disc" => "",
		"con"  => "10-0",
		"ac"   => 0,
		"attl" => 1,
		"size" => 100 );

sub chklnk
{ local ($file) = @_;
  if (-l $file)
  { readlink($file);}
  else
  { $file;}
}

#####################
# moves objects.  Uniquifies name as necessary
# return values
# 1	size will not fit
# 2	$what can't be found
# 3	$to error
# 4	$from error
# 5	$to is locked
sub move
{ local ($what, $from, $to) = @_;
#  local *whatg;
#  local *dest, *basematch;
  $what || return 2;
# get stats of $what for checking
  open (WG, "$from$what/.stats") || return 2;
  %whatg = &read_stats (*WG);
  close (WG);
# lock, get stats for destination
  ($destf = &lock ("$to.stats")) || return 3;
  %dest = &read_stats ($destf);
# check lock
  if ($dest{'lock'})
  { $whatg{$dest{'lock'}} || return 5;
  }
# check sizes
# print "$what size $whatg{'size'}\1n";
# print "$to size $dest{'size'}\1n";
  ( $whatg{'size'} < $dest{'size'} ) ||
    (&unlock ($destf), return 1);
# extract base name of $what
  $whatb = $what;
  $whatb =~ /(\1w)+_\1d*/ ;
# find any objects in $to with the same base name
  opendir (D, $to);
  @basematch = grep(/$whatb/, readdir(D) );
  closedir (D);
# transilate to easily searched form
  foreach $cnt (@basematch)
  { $basematch{$cnt} = 1;}

  if (@basematch)
# find an unused label
  { for ($cnt = 1; !$basematch{$whatb."_$cnt"}; $cnt++) {}
    $whatb = "$whatb_$cnt";
  }
# we have a unique label, move
  rename($from.$what, $to.$whatb) ||
   ( &unlock ($destf), 4);
  &unlock ($destf);
  0;
}

######################

sub resolve_obj
{ local @lookin = @_;
  my $objshort = uc shift @lookin;
#  my $obj, $found;
  local *looki;
# scan all directories in @lookin
  foreach $looki (@lookin)
# does any file present match /$objshort/ ?
  { opendir (LI, $looki);
    while ($obj = (readdir(LI)) )
    { if (uc ($obj) =~ /^$objshort/)
      { closedir (LI);
        $obj = &chklnk($obj);
        return ($obj, $looki);
      }
    }
    closedir (LI);
  }
  0;
}

############################
1;
# login.pl
# login routines for dirmud

sub login
{ $/ = "\1r";
  print "lsmud$n$n login$n";
  do
  { print "your character.$n 'new' if first time,$n 'exit' to quit$n>";
    $ucpname = uc(<>);
    print $ucpname;
    $ucpname =~ s/\1s//g;
    if ($ucpname eq "NEW")
    { &new_player;
    }
    if ($ucpname eq "EXIT")
    { die "Hope to see you later$n";
    }
    if (!(-l "players/$ucpname"))
    { print "$n Invalid Character: $ucpname$n$n";
      sleep (2);
    }      
  } until (-l "players/$ucpname") ;
# log in
  $pdir = readlink("players/$ucpname");
#  print ($pdir, $n);
  chdir ($pdir);
  if (rename ("../.$ucpname" , "../$ucpname" ))
  { # check password
    open (selff, ".stats");
#    seek (selff, 0, 0);
    print "logged in$n";
  }
  else
  { print "character is already logged in$n",
     "e-mail administraitor @ $admin$n";
     die;
  }
  $pname= $ucpname;
  $/ = "\1n";
  
}

sub logout
{ if ($xmit) { return; }
# change to current dir, fix pwd?
#  chdir ('../'.$ucpname);
  rename ("../$ucpname", "../.$ucpname");
# find character
  $wd = &finder(".$ucpname","$HOME/wldroot");
  unlink ("$HOME/players/$ucpname");
  symlink ("wldroot/$wd" ,"$HOME/players/$ucpname"); 
  close (selff);
#  kill 'INT', $child;
}

###############################################
#collect stats and create a new character
sub new_player
{ local (*stats);
# get a valid name
  do
  { print "$n name your character >";
    $ucpname = uc (<>);
    $ucpname =~ s/\1s//g;
    if ($bn=(-l "players/$ucpname"))
    { print "$n'$ucpname' is already taken$n";
    }
  } until (!$bn);
print "hello $ucpname$n";
# create directories, linkage
  $sr = readlink('start_room');
  mkdir ("$sr/.$ucpname", 0700);
  symlink("$sr/.$ucpname", "players/$ucpname");
# get a discription of the character
  print "enter a 1 line discription of your character:$n";
  $pdisc = <>;
  print "Your e-mail?> ";
  $email = <>;
# create stat files
  chdir ("$sr/.$ucpname"); 
  open (stats, ">.stats");
  %stats = %default_stat;
  $stats{'disc'} = $pdisc;
  $stats{'email'} = $email;
  &write_stats(*stats, \1%stats);
  close (stats);

  chdir($HOME);
# a message to the player
  print ("You should be able to find what you need to get started$n",
	"around town.  type 'help' for help$n");
}
# finder.pl
# finds a file
# finder (file, whr);
sub finder
{ my($filespec, $whr) = @_;
  local *path;
  my $search, $whrpth;
  opendir path, $whr;
  while ($path = readdir(path))
  { $whrpth = $whr.'/'.$path;
    if ($path =~ /^$filespec/)
    { return ($path); }
    if ( (-d $whrpth) && ($path !~ /^\1./) )
    { if ($search = &finder($filespec, "$whr/$path"))
        { return "$path/$search";}
    }
  }
  0;
}
1;\eof
file:server:100700
#!/usr/bin/perl
use strict;
use Socket;
use Carp;

my $port = shift || 1067;
my $proto = getprotobyname('tcp');
$port = $1 if $port =~ /(\1d+)/; # untaint port number

socket(Server, PF_INET, SOCK_STREAM, $proto) &&
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) &&
setsockopt(Server, SOL_SOCKET, SO_KEEPALIVE, pack("l", 1)) &&
bind(Server, sockaddr_in($port, INADDR_ANY)) &&
listen(Server, 5)
	|| die $!;

$SIG{'CHLD'} = sub{wait};

while (accept(Client,Server))	
{# print "connection\1n";
  if (!fork)
  { close Server;
    open(STDIN,  "<&Client") &&
    open(STDOUT, ">&Client") || die "can't dup to stdio";
    exec './lsmain' || die "can't exec lsmud: $!";
  }
  close Client;
}
\eof
file:lsmain:100755
#!/usr/bin/perl
################
# main program #
################
require "lsmud";
# unbuffered stdout
$| = 1;

&login;

# create a message fifo
if (!(-p ".msg"))
{ if ( system('mknod',  ".msg", 'p') && system('mkfifo', ".msg") )
  { die "'ear' creation failed";
  }
}

# prepare IO
open (MSG, "+<.msg");
# stdin, stdout already open
fcntl(MSG,F_SETFL(),O_NONBLOCK());
# block next line for single step
fcntl(STDIN,F_SETFL(),O_NONBLOCK());
$read_set = new IO::Select;
$read_set->add(\1*STDIN);
$read_set->add(\1*MSG);
print "entering the world of lsmud$n$n>";

# main loop
while ($cmd ne 'quit') #&& ($cmd ne 'logout'))
{ ($open_handles) = IO::Select->select($read_set, undef, undef, 30);
# try each input
  &incoming_msg();
  &incoming_command();
  $open_handles || print "well?$n>";

} # leaving main loop
&logout;
\eof
dir:wldroot
file:.stats:100644
imm_gold,900
disc, This is the world of rogues tale.  You are in the land of Longdock Isle.  Outside there be lands unknown.  Inside there be ADVENTURE!
size, 1000
\eof
file:.top:100644
disc, This is the world of rogues tale.  You are in the land of Longdock Isle.  Outside there be lands unknown.  Inside there be ADVENTURE!
\eof
dir:Bay
file:.stats:100644
disc, A large protected bay at the east end of Longdock isle.
size,500
\eof
link:Est_beach:../Est_beach

link:Nor_beach:../Nor_beach

link:S_beach:../S_beach

link:longdock:../longdock

link:manor_house:../leach_manor

edir
dir:Est_beach
file:.stats:100644
size,500
\eof
edir
dir:Nor_beach
file:.stats:100644
size,500
\eof
edir
dir:S_beach
file:.stats:100644
size,500
\eof
edir
dir:leach_manor
file:.stats:100644
disc,The manor of Baron Leach
size,750 
\eof
dir:horse
file:.stats:100644
con,10-0
disc,this is the Barons favorite horse
size,100
imm_gold,100
ac,0
attl,1
\eof
edir
dir:manor_house
file:.stats:100644
con,10-0
disc,A large house from which Leach Manor is directed
ac,0
ttl,1
attl,1
imm_gold,100
size,1000 
\eof
edir
edir
dir:longdock
dir:market
file:.stats:100644
disc,A simple market shop.
size,500
\eof
edir
dir:guard
file:.stats:100644
desc,A burly guard
size,150
attl,5
\eof
file:.life:100700
#!/usr/bin/perl
# dumb guard, hits anyone who trys to start a fight
require "../../lsmud.pl";

open (msg, "+<.msg");
while ($msg = <msg>)
{ if ($msg =~ /hits/)
  { &attack(split(' hits', $msg) ); }
}
\eof
edir
file:.stats:100644
email, 

con, 10-0
disc, 

size, 100
ac, 0
attl, 1
\eof
dir:bilbows
file:.stats:100644
disc,Bilbows Bows.  An archery and woodcraft shop.
size,500
\eof
dir:Bilbow
file:.stats:100644
disc, Bilbow Underhill.  Propriater of Bilbows Bows.  A Jovial Halfling.
size, 50
\eof
edir
edir
dir:critter
file:.stats:100644
con,10-0
size,50 
imm_gold,100
disc,a small wild critter
ac,0
attl,1
\eof
edir
dir:gordo
file:.stats:100644
disc, a small timid lizzard.
moredisc, it looks afraid, as if scolded too often
size, 20
 
\eof
edir
dir:shipyard
file:.stats:100644
desc, boats of various sizes, mostly for fishing, are built here.
size, 450
\eof
edir
dir:smithy
file:.stats:100644
disc, The local blacksmiths shop.  Here can be found or ordered almost any item from plowshares and door hinges to fine swords and armor.
size, 300
\eof
edir
dir:tannery
file:.stats:100644
desc, Anything leather can be ordered here.
size, 450
\eof
edir
dir:tavern
file:.stats:100644
disc,Bart Station Inn.  A waystation where you can find food, drink, or a room for the night.  Or, if you prefer, try your luck at a gaming table.
size,500
\eof
dir:bar
file:.stats:100644
desc, The local watering hole.
size, 350
\eof
edir
dir:game_table
file:.msg:100644
\eof
file:.stats:100644
desc, try your hand at a game of poker or merrels.
size,250 
\eof
edir
dir:upstairs
file:.stats:100644
desc, several rooms to rent for the night.
size, 350
\eof
dir:master_room
file:.stats:100644
size, 350
\eof
edir
dir:room1
file:.stats:100644
size, 350
\eof
edir
dir:room2
file:.stats:100644
size, 350
\eof
edir
dir:room3
file:.stats:100644
size, 350
\eof
edir
dir:room4
file:.stats:100644
size, 350
\eof
edir
edir
dir:greenjewel
file:.stats:100644
disc, A strange green jewel, it shines brightly, almost glowing.
moredisc, On the underside is inscribed "tickle me".
size,5
imm_gold,100
\eof
file:.tickle:100644
#!/bin/bash
echo He He He.
echo A sprite is traped inside the stone.
echo '"please help me"'
\eof
edir
edir
dir:.PETE
file:.stats:100644
email, hanelyp@calweb.com
con, 10-0
disc, a test
size, 100
ac, 0
attl, 1
\eof
edir
dir:.POGO
file:.stats:100644
email, 
hanelyp@calweb.com
con, 10-0
disc, 
a test
size, 100
ac, 0
attl, 1
\eof
edir
edir
edir
dir:players
link:PETE:wldroot/longdock/.PETE
link:EXIT:wldroot/0
link:POGO:wldroot/longdock/.POGO
edir
link:start_room:wldroot/longdock
file:help:100644
get|take <what>
drop|throw <what>
give <what> <who>
look|read <what>
examine <what>		you must own <what>
inventory

say [who] <message>

attack <who>
wear <what>		wear a set of armor(or other item)
wield <what>		use a given weapon

go|goto|move <where>
exit			leave a room

help|? [command]

quit

\eof