#!/usr/bin/perl

use vars qw($MXPERL_PORT);

#$MXPERL_PORT = 2345;

#use diagnostics;

	$~ = '::USER_RECORD';
    	$^ = '::USER_RECORD_TOP';


BEGIN {
    # this is done here
    # so that we can bail early if need be before the use's

$diagnostics::MAXLINELEN = 1000;

    CONFIG: {
	$SERVER_SOCK = '/tmp/MTG-public-sock';
	$SAFE_UID = $SAFE_GID = 40;
	$BOXDIR = '/usr/tmp';
    } 

    if (@ARGV) {
	if (@ARGV == 1) {
	    $SERVER_SOCK = $ARGV[0];
	} else {
	    die "Usage: $0 [socketfile]\n";
	} 
    } 

} 


use English;
use FileHandle;
use Carp;
use Socket;
use CGI::Base;
use MTG::Query;
use MTG::PrintRuns;
use MTG::GenFormat;
use MTG::Text_Utils;
use MTG::BitCvt;	# C module
use Const;		# C module

eval q{
    package main; 	use String::Approx qw(amatch); 
    package MTG::Query; use String::Approx qw(amatch); 
}; 

$^W = 0;

####disable diagnostics;

if (0 and -t STDIN && -t STDOUT) { 
    $LOGFILE = "/dev/tty";
} else { 
    $LOGFILE = "/tmp/mx.log";
}
#CGI::Base::LogFile("/tmp/mxperl.log"):

use IO::Handle;
STDERR->autoflush(1);

$FORMAT_LINES_LEFT = $FORMAT_LINES_PER_PAGE = 5_000;

if ($INTERACTIVE = defined $DB::VERSION) { 
    $DEBUG = 1;
    $MAX_DIRECT_XFER = 1e6;
    CGI::Base::LogFile("/dev/tty");
} else { 
    $DEBUG = 0;
    $MAX_DIRECT_XFER = 0;
    CGI::Base::LogFile ($::LOGFILE);
}

sub logmsg {
    if ($INTERACTIVE) {
	print STDERR "LOGMSG: @_\n";
    } else {
	$CGI_Obj->log(@_);
    } 
} 

$SYS_gettimeofday  = 78;

init();
load_texts();

# $SIG{'INT'} = sub { confess 'interrupt' };

dump_db();

use DB_File;
dbmopen(%Rulings_DB, "rulings.db", undef) || warn "no rulings db: $!";

if ($INTERACTIVE) { 
    normal_input();
} else { 
    start_server();
}

die "Not Reached";

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

sub getline {
    local $_; local ($line) = '';  # DYNAMIC
    do { 
	prompt();
	eval { $line = <CLIENT> };
    } while $line =~ /^\s+$/ || $_ =~ /interrupt/;
    return $line;
} 

sub normal_input { 
    local *CLIENT = *ARGV;
    $SKIP_CARDS = 1;
    #local $^W = 1;
    sub prompt { print "Request> " };
    while ( defined($_ = getline()) ) {
	last if !defined $_ or $_ eq '';
	last if /^q(uit)?$/i;
	%warned = ( 'Subroutine criteria redefined' => 1 );
	eval { &process_request };
	warn $@ if $@;
    } 
}

sub process_request {
    hthead();

    # this will set nodups
    user_sort($R::sort || 'name');

    if (0 and 0 == system('/usr/local/etc/ftpucheck', $R::login)) {
	print <<ENDIT;
</PRE>
<B>Bad email address: <tt>$R::login</tt></B>
<P>
The reason I want your address is in case you are having problems
devising a query.  
You will never received unsolicited bulk email
simply because you've placed something here.
<P>
ENDIT
	trailer();
	return;
    } 

    print <<ENDIT  if 0;
    # print <<ENDIT unless $R::login =~ /\w+\@\w+/;
</PRE>
<P>
<BLOCKQUOTE>
<STRONG>

    Hey there: You didn't tell me who you are.  While I entirely respect
    your right to privacy, I'd like you to please include your email
    address in your query next time.  Otherwise, I'm not going to be able
    to help you if things don't work out.  And I'd honestly like to do that.

</STRONG>
</BLOCKQUOTE>
<PRE>
ENDIT

    unless ($R::format) {
	$R::format = 'name cost@>6 powtuf@| n_printrun color type';
    } 

    if ($R::format) {
	if (not MTG::GenFormat::generate_formats($R::format)) {
	    print <<ENDIT;
</PRE>
<P>
<CODE>Format Error: $@</CODE>
<BLOCKQUOTE>

	    I'm afraid that your formats didn't compile.  
	  	     
ENDIT
	    if ($@) { 
	    print " This probably won't mean much to you, but here they were:";
	    code_debug("failed formats", 
		$MTG::GenFormat::Form_Header . "\n\n" . $MTG::GenFormat::Form_Body);
	    return;
	    }
	} 
	$~ = '::USER_RECORD';
    	$^ = '::USER_RECORD_TOP';
    } else { 
	logmsg("Using default format");
	$~ = '::DEFAULT';
    	$^ = '::DEFAULT_TOP';
    }

    local($code) = $_;

    if (/### REPLACE THIS LINE ###/) {
	logmsg("forgot to replace");
	print qq(</PRE><P>I <b>told</b> you to replace the selection line and
supply your own selection choices.  Didn't you ever read that? <P>Perhaps
you should consider using the <A HREF="/deckmaster/forms/mx-frontend.html">simple
query compiler</a> so you don't have to know how to program?);
	trailer();
	return;
    } 


    if  ( compile($_) ) { COMP: {
	my %seen;
	*this = *_;  # so greps work
	*MTG::Query::this = *this;
	$::All_Cards_OK ||= $R::login =~ /tchrist\@/;
	$done = $start = pack("LL", ());
####	disable diagnostics;
	eval q{ 
	    alarm $QTIME unless $DEBUG;
	    if (-1 == syscall( $SYS_gettimeofday, $start, 0)) { die "gettimeofday 1: $!" }
	    @cards = grep (&MTG::Query::criteria, @MTG::HashDB::Cards);
	    if (-1 == syscall( $SYS_gettimeofday, $done, 0)) { die "gettimeofday 2: $!" }
	    alarm 0;
	};
	alarm 0;
####	enable diagnostics;
	@start = unpack("LL", $start);
	@done = unpack("LL", $done);
	$delta_time = sprintf "%.4f",
	    (( $done[0] + ($done[1]/1e6) ) - ( $start[0] + ($start[1]/1e6) ));
	$ENV{delta_time} = $delta_time;
	if ($delta_time < 1) { $delta_time = "merely " . $delta_time; } 

	if ($EVAL_ERROR =~ /Query timed out/) {
	    die;
	}  elsif ($EVAL_ERROR) { 
	    &mungeat;
	    print "</PRE><H2>Run time Error!</H2>";
	    &codedump(0);
	    #print "</PRE><H2>Run time Error!</H2><PRE>$EVAL_ERROR</PRE></B>\n";
	print "<P></B><STRONG>IMPORTANT: Please resubmit this and include your login field where it's asked for so I may help you!</STRONG>\n" unless $R::login;

	    logmsg("Run time Error! $EVAL_ERROR");
	    last COMP;
	} 

	if ( $::Trim_Duplicates ) { 
	    my %seen = ();
	    @cards = grep { !$seen{ $_->{sort_name} }++ } @cards;
	} 

	printf "</PRE>%d match%s ", scalar @cards, scalar @cards == 1 ? '' : 'es';
	print "in $delta_time seconds at ", `date`, "\n<P><PRE>";
	logmsg( sprintf "\t#$Request_No found %d cards in $delta_time seconds", scalar @cards);
	# last COMP unless scalar @cards;
	# last COMP if $SKIP_CARDS;
	$FORMAT_LINES_LEFT = 0;
	$FORMAT_LINES_PER_PAGE = 5_000;
	if (@cards == 0) {
	    print <<EOW;
</PRE>
<CENTER>
<H2>WARNING</h2>
</CENTER>
   <P> Now that's odd: You query failed to return anything at all.
   If you think it should have given you something, maybe you just got
   the perl code wrong.  (Don't feel bad - this happens to me all the
   time. :-) <P> Did you check out the
<A Href="/deckmaster/info/query_examples.html">simple examples</a>
   or the
<A HREF="/deckmaster/info/GenCard.html">more extended tutorial</a>?
    Better yet, Did you know you can now use the
   <A HREF="/deckmaster/forms/mx-frontend.html">simple query compiler
   form</a> so you don't have to know how to program?  It will always
   show you the real query, which means that you'll be able to use
   it as an interactive tutorial.  I highly recommend it.  Then again,
   there's always the <A HREF="/deckmaster/cards/Canned.html">Canned
   Listings</a> for the most popular requests.  Did you look there?
   <P>If all else fails, please feel free to mail me.  <P>
EOW
	    trailer();
	    return;

	} elsif (@cards > ($MAX_CARDS * .59) && ! $::All_Cards_OK) {{
	    if (0 and $R::login =~ /\S+\@\S+\.\S+/) {
		last if 0 == system("/usr/local/etc/ftpucheck", $R::login);
	    } 
	    my $percent;
	    if (@cards == $MAX_CARDS) {
		$percent = "all $MAX_CARDS";
	    } else {
		$percent = int (100 * (@cards / $MAX_CARDS)) . "% of the $MAX_CARDS";
	    }
	    print <<EOW;
</PRE>
<CENTER>
<H2>WARNING</h2>
</CENTER>
   <P> You appear to have selected $percent possible cards.
   If this wasn't intentional, you may have given a query
   that's always true.  Did you know you can look at the <A
   HREF="/deckmaster/cards/Canned.html">Canned Listings</a> for most of
   this.  <B><P>I now restrict most queries that return more than 60% of the cards.
   <P> Use the <A HREF="/deckmaster/cards/Canned.html">Canned
   Listings</a> or download the 
   entire database in 
<A HREF="http://www.perl.com/perl/mox/MTG::Descriptions.pm.gz">compact</a>
or 
<A HREF="http://www.perl.com/perl/mox/expanded-dbase.pl.gz">expanded</a>
form.
<PRE>
EOW
	    return;
	}} 

	$::All_Cards_OK = 0;  # reset please

	prepare_cat() if @cards > $MAX_DIRECT_XFER;

	$done = $start = pack("LL", ());
	if (-1 == syscall( $SYS_gettimeofday, $start, 0)) { die "gettimeofday 3: $!" }

####	disable diagnostics;
	my @ordering = sort MTG::Query::sort_ordering @cards;
####	enable diagnostics;

	if (-1 == syscall( $SYS_gettimeofday, $done, 0)) { die "gettimeofday 4: $!" }
	@start = unpack("LL", $start); @done = unpack("LL", $done);
	$ENV{sort_time} = sprintf "%.4f",
	    (( $done[0] + ($done[1]/1e6) ) - ( $start[0] + ($start[1]/1e6) ));

	my $lastkey = 'INITIAL BOGOSITY';
	my $metakey = 'THIS WILL NEVER HAPPEN';
	my $sort_key = $::Primary_Sort || 'name';
	my $splitem;

	$splitem = 1 unless $sort_key =~  /name/i;
	$splitem = 0 if $MTG::GenFormat::No_Sort_Headers;

	if ($splitem) { 
	    #$sort_key = 'n_release' if $sort_key eq 'release';
	    $sort_key = 'v_release' if $sort_key eq 'release';
	    # $sort_key = 'v_rarity' if $sort_key eq 'RARITY';
	    $sort_key = 'type' if $sort_key eq 'metatype';
	} 

	# $= = 100;
	$FORMAT_LINES_LEFT = 0;
	$FORMAT_LINES_PER_PAGE = 5_000;

	for $_ ( @ordering ) {
	    my $varname;
	    no strict 'refs';
	    for $varname ( keys %MTG::GenFormat::Make_Copy ) {
		${"V::$varname"} = $_->{$varname};
	    }
	    use strict 'refs';
	    if ( $splitem and $_->{$sort_key} ne $lastkey) {

		if ($sort_key eq 'color' ) {
		    unless ($metakey = $_->{color}) {
			$metakey = $_->{type};
			$metakey =~ s/^(Summon|Artifact).*/$1/;
			$metakey =~ s/^(Enchant).*/Enchantment/;
			$metakey =~ s/^Legendary (\S.*)/$1/;
		    }
		} elsif ($sort_key eq 'type' ) {
		    $metakey = $_->{type};
		    if ($::Primary_Sort eq 'metatype') {
			$metakey =~ s/^(Summon|Enchant|Artifact).*/$1/;
			$metakey =~ s/^Legendary (\S.*)/$1/;
		    } 
		#} elsif ($sort_key eq 'v_release') {
		} elsif ($sort_key =~ /release/) {
		    $metakey = $_->{v_release};
		    #$metakey =~ s/\s*(,|\band\b|\().*//;
		} elsif ($sort_key eq 'first_rarity') {
		    $metakey = $_->{v_rarity};
		    $metakey =~ s/.*?(Land|Rare|Common|Uncommon).*/$1/;
		} elsif ($sort_key =~ /rarity/) {
		    $metakey = $_->{v_rarity};
		    #$metakey =~ s/.*(Land|Rare|Common|Uncommon).*?/$1/;
		    $metakey =~ s/.*(Land|Rare|Common|Uncommon).*/$1/;
		} elsif ($sort_key eq 'cost') {
		    $metakey = $_->{ncost};
		} elsif ($sort_key =~ /price|average|high|low|stddev|change/i) {
		    $metakey = int($_->{$sort_key});
		    if ($metakey > 10 and $metakey < 100) {
			my $floor = $metakey;
			$floor /= 10;
			my $ceil = $floor;
			$ceil = int($ceil + 0.99999999);
			$floor = int($floor);
			for ($floor, $ceil) { $_ *= 10 } 
			if ($floor == $ceil) {
			    $ceil += 10;
			} 
			$metakey = "$floor - $ceil";
		    } elsif ($metakey > 100) {
			$metakey = '$100+';
		    } 
		    $metakey =~ s/^/\$/;
		} else {
		    $metakey = $_->{$sort_key};
		} 

		$metakey =~ s/(\w+)/\u\L$1/g; #  unless $sort_key =~ /cost/i;
		if ($metakey ne $lastkey  and plural($metakey) ne $lastkey
		    and $metakey ne plural($lastkey)
		    and plural($metakey) ne plural($lastkey)
		    )
		{
		    my $nice_sort_key = '';
		    if ($metakey =~ /^\d/) {
			$nice_sort_key = "\u\L$sort_key " unless $sort_key eq 'inprint';
		    } 
		    $lastkey = $metakey;
		    1 while $metakey =~ s/^(\s*[+-]?\d+)(\d{3})/$1,$2/;
		    print "</PRE><P><HR><P><H2>$nice_sort_key$metakey Cards</H2><PRE>";
		    $- = 0;
		}
	    } 
	    eval { write };
	    if ($@) { 
		print "Sorry that output format didn't work: $@";
		warn "format failed: $@"; last;
	    } 
	}

=comment


	if ($~ !~ /_/) {
	    warn "use format $~ missing";
	} 
	for $_  (@ordering ) {
	    #$htname = "/deckmaster/cards/" . safename($_->{"name"});
	    #print qq{<A HREF="$htname">};
	    $this->{name} =~ s/Circle of Protection/CoP/;
	    #$this->{name} = crit($this->{name});
	    write;
		# unless $seen{$this->{"name"}}++;
	}

=cut

    }} else {
	if ($EVAL_ERROR) {
	    &codedump;
	} 
    } 

    #print "</PRE></body>\n";
    print "</PRE>\n";

    trailer();
    kick_the_cat() if @cards > $MAX_DIRECT_XFER;
}

sub prepare_cat {
    logmsg( "prepping kitty");
    srand(time | $$);
    my $pidish = int(rand(10000));
    srand($$ | time);
    ($pidish = rand) =~ s/.*\.//; 
    $pidish = substr($pidish,-5);
    $dir = '/scratch/card-listings';
    unless (-d $dir) {
	if (!mkdir($dir, 0777) ) {
	    logmsg( "can't mkdir $dir: $!");
	    return;
	} 
    } 
    $ENV{CARD_LISTING} = 
	$tempname = "/scratch/card-listings/spool.$pidish";

    open(STDOUT, ">$tempname") || die "can't open $tempname: $!";

	open(STDERR, ">&SAVE_ERR") 
	|| open(STDERR, ">>$::LOGFILE")
	|| open(STDERR, ">/dev/tty") ;
}

sub kick_the_cat {
    $| = 1;
    print '';
    # close STDOUT;
    open(STDOUT, ">&CLIENT");
    system "/usr/local/bin/suicide_cat &";
} 

sub trailer {
    my $db_update  = localtime((stat($INC{"MTG/Descriptions.pm"}))[9]);
    if ( `date` =~ /\s+(\S+)\s+\d{4}$/ ) { $db_update .= " $1" } 
    print <<"EOC";

<HR>

<P>
Other resources on this site:

<UL>

<LI><IMG SRC="/deckmaster/gifs/new.gif" WIDTH=26 HEIGHT=13 ALT="NEW"> <A HREF="/cgi-bin/MxScreen">Non-Programmers' Interface</a> to the Query Generator
<LI><A HREF="/deckmaster/forms/mx-backend.html">Hackers' Interface to the Query Generator</a>
<LI><A HREF="/deckmaster/cards/index.html">Card Index and Fuzzy Matcher</a>
<LI><A HREF="/deckmaster/cards/Canned.html">Canned Listings</A>
<LI>The <A HREF="/deckmaster/forms/angelgrep.html"><i>AngelGrep</I> Rules Search Engine</A>
<LI><A HREF="/deckmaster/index.html">Main MtG Index</A>
<LI><A HREF="/deckmaster/cards/acknowledgements.html">Acknowledgments and Disclaimers</a>
<LI><A HREF="mailto:tchrist\@mox.perl.com">Mail Feedback to Author</a>
</UL>

<HR>
<I>
Last server update: $SCRIPT_UPDATE
<BR>
Last database update: $db_update
</I>
</UL>
EOC
}

sub hthead {
    $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin/:/usr/ucb';

    return if $SKIP_CARDS;

    my $title = "Direct Query Results";

    my $url = mkurl();

    sub mkurl { 
	use URI::URL;
	my $url = new URI::URL 'http://mox.perl.com/cgi-bin/pxgenlists';
	my @args = ( card_request  => $R::query );
	push @args, 'sortfunc'    => $R::sort 	    if $R::sort;
	push @args, 'format'   	   => $R::format    if $R::format;
	$url->query_form(@args);
	return $url;
    }

    print <<EOT unless $R::origin =~ /MxScreen/;

<HTML><HEAD><TITLE>$title</TITLE>
<LINK REV=MADE HREF="mailto:tchrist\@mox.perl.com">
<META NAME="keywords" CONTENT="perl magic mox">
<META NAME="copyright" CONTENT="Copyright 1998 Tom Christiansen">
</HEAD>
<BODY BGCOLOR="#FFFFFF" VLINK="#663366" TEXT="#000000" LINK="#3333FF" ALINK="#CC0000">
EOT


    print <<EOT;
	<H1>
<A HREF="http://www.perl.com/"><IMG 
SRC="http://www.perl.com/graphics/perl_id_313c.gif" ALT="Programming
Republic of Perl" WIDTH="90" HEIGHT="90" ALIGN="bottom"></A>

	$title
	</H1>

    <A HREF="$url">Rerun</A> this query.

	<P>

EOT

    if ($R::query) {
	print  "<CODE><PRE><DL>\n";
	print "<DT><B>SELECT =></B><DD>", html_escape($R::query), "\n";
	print "<DT><B>SORT   =></B><DD>", html_escape($R::sort), "\n" 	if $R::sort;
	print "<DT><B>FORMAT =></B><DD>", html_escape($R::format), "\n"	if $R::format;
	print "</DL></PRE></CODE>\n";
	print "<PRE>\n";
    } 
}


sub no_evil_hacks { 
    local $^W = 0;
    study;

    local $Hacked = 0;

    sub check_hack {
	if ($_[0]) {
	    $Hacked++;
	    logmsg("HACKER ALERT: $1");
	} 
    } 

    check_hack /(::)/;
    check_hack /([\@\$%&]'\w)/;
    check_hack /([\@\$%]&\{)/; # }
    check_hack /(`)/;
    # check_hack /([.+\-*\/%x&|^]=)/;
    check_hack /(\beval\b)/;
    check_hack /(\bsystem\b)/;
    check_hack /(\bexec\b)/;
    check_hack /(\bexit\b)/;
    check_hack /(\bpackage\b)/;
    check_hack /(\bfork\b)/;
    check_hack /(\bqx\b)/;

    return $Hacked == 0;
} 

sub compile {
    local($_) = shift;
    unless (no_evil_hacks()) {
	print "</PRE><B>Compilation Error: <I>Permission denied.</I></B>\n";
	logmsg( "An evil hacker has been apprehended; cf $Requestor");
	return 0;
    } 
    # s/(!!|^but\b)/$lastquery/g if defined $lastquery;
    local $orig = $_;
    1 while s,(['/"].*?\1),saferepl($1),gi;
    s/(\w+(\.\w+)+)/($1)/gi;
    s/\bnor\b/||/g;
    s/\bnon\b/!/g;
    s/\r/\n/g;
    #s/\bhas\s+([^\s)]+)/=~ m{$1}is/g;
    #s/\bis\s+([^\s)]+)/=~ m{^$1$}gis/g;

    s/\b([1-5])e\b/E$1/gi;

    if ( m{=~\s*([a-lnzA-Z0-9'"]|m\w)} ) {
	print <<'EOBITCH';
</PRE>
<H1>
Compilation Error
</h1>
<P>
You can't use =~ on a string (or a function call, since
they all return  true or false in a way you're not expecting.)
Proper form is one of these:
<PRE>
    FIELD() =~ /something/    [patterns]
    FIELD() =~ m{something}   [same thing, but you can match /'s]

    FIELD() =~ /something/i   [case insensitive patterns]
    FIELD() =~ m{something}i  [same thing, but you can match /'s]
</PRE>
<P>

You don't seem to be a perl programmer.  Might I suggest you try the fool-proof
<LI><A HREF="/deckmaster/forms/mx-frontend.html">Non-Programmers' Interface to this List Generator</a>
instead?
EOBITCH

	logmsg( "stupid match");
	return 0;

    } 

    if (/\w+\s*[!=]=\s*['"`a-zA-Z]/) {
	print <<'EOBITCH';
</PRE>
<H1>
Compilation Error
</h1>
<P>
You can't use == or !\ on a string (or a function call, since
they all return  true or false in a way you're not expecting.)
<P>
You have to do
<PRE>
    FIELD() == somenumber     [NUMBERS ONLY!!!!!!!!!]
    FIELD() eq 'something'    [exact strings]
    FIELD() =~ /something/    [patterns]
    FIELD() =~ /something/i   [case insensitive patterns]
</PRE>

You don't seem to be a perl programmer.  Might I suggest you try the fool-proof
<LI><A HREF="/deckmaster/forms/mx-frontend.html">Non-Programmers' Interface to this List Generator</a>
instead?

<P>
EOBITCH
	logmsg( "stupid equals");
	return 0;
    } 

    if (0 and m{\w+(\(\s*\))?\s*=\s*[/a-zA-Z]}) {
	    print <<'EOBITCH';
</PRE>
<H1>
Compilation Error
</h1>
<P>
You can't use make assignments.  That's what = does.  
<P>
You have to do
<PRE>
    FIELD() == somenumber     [NUMBERS ONLY!!!!!!!!!]
    FIELD() eq 'something'    [exact strings]
    FIELD() =~ /something/    [patterns -- NOTE THE TILDE! ]
    FIELD() =~ /something/i   [case insensitive patterns]
</PRE>

You don't seem to be a Perl programmer, or even a C programmer.  Might I
suggest you try the fool-proof <LI>
<A HREF="/deckmaster/forms/mx-frontend.html">Non-Programmers' Interface to
this List Generator</a> instead?  

<P>

EOBITCH
	logmsg( "stupid assigment");
	return 0;
    } 

    s/\bbut (.*)/and ( $1 )/g;

    tr/\200-\377/\000-\177/;
    s/^[\s;]*//;
    s/\s+$//;
    # print "\n\t$_\n";
	    # BEGIN { (\$^W, \$^H)  = (1, 0x600); } 
    my @allsubs = /(\w+)/g;
    @allsubs = grep( ! ( /\b(and|int|uc|lc|abs|or|but|not|nor|eq|ne|le|gt|ge|lt|length)\b/ || defined &{"MTG::Query::$_"}), @allsubs);
    %MTG::Query::did_Load = ();
    %MTG::Query::called = ();
    $MTG::HashDB::Cards_OK = 0;
####    clear diagnostics;
    $code = qq{
	package MTG::Query; 
	sub criteria {  
	    use strict qw(subs vars);
	    use subs qw(@allsubs);
	    return ($_);
	    ##      ^      your code began right there
	} 
	'Success!';
    }; 
    $code =~ s/^\n//;
    die "no query fields" unless @MTG::Query::Fields;
    my $field_check = uc (join ('|', @MTG::Query::Fields));
    $code =~ s/\b($field_check)(\s*\(\s*\)\s*)?/\$_->{\L$1\E}/go;
    code_debug('Generated Select Code', $code);
    if ($R::debug) { print "<HR>" }
####    enable diagnostics;
	my $rv = eval $code;
####    disable diagnostics;
    if ($EVAL_ERROR || !$rv) { 
	&codedump(1);
	if (!$EVAL_ERROR || $EVAL_ERROR =~ /bare\s*word/i) {
	    0 and print <<ENDIT;
<P>If you got an error message about barewords not being allowed, remember
that in general, you have to type boolean comparisons, not just words by themselves.  
The barewords message means that you typed something which was not either
a built-in field references (like TEXT) or else not a valid helper
function name.  The <A HREF="/deckmaster/info/GenCard.html">tutorial</a>
will show you a list of valid field references, helper functions, and
examples of the comparison operators.  <P>You might also have to use
quotes around your string if it contains a space.  The special = pattern
operator only works with single words on its right-hand-side.  The most
common mistake is saying something like
<PRE>
    giant
    TEXT = giant
</PRE>
and meaning one of these
<PRE>
    TYPE   =~ /giant/i
    NAME   =~ /giant/i
    TEXT   =~ /giant/i
    FLAVOR =~ /giant/i
    CARD   =~ /giant/i
</PRE>
The first one is just a bareword, which isn't allowed.  The second
one is an assignment, not an equality check.
<P>
Finally, you may wish to check out the long explanation for whatever
warning or error you got  in the 
<A HREF="http://www.metronet.com/1h/perlinfo/perl5/manual/perldiag.html">
Perl Diagnostic Descriptions
</a>.
ENDIT

	    print <<ENDIT;
		<P>
		Looks like this didn't work out.  It's probably because you
		don't understand perl or else you don't understand my predefined
		queries.
ENDIT

	    print <<ENDIT unless $login;
		<BLOCKQUOTE>
		<STRONG>
		<P>VERY IMPORTANT: If you don't supply an
		email address in your query, I'm not going to be able to help you.
		<I>
		Please resubmit and add your internet email address to the 
		place in the form that asks for it.
		</I>
		</STRONG>
		</BLOCKQUOTE>
ENDIT

	    print <<ENDIT if $login;
		If I have time and remember to look, I'll check the logs and
		try to get back to you with email if it appears you still haven't 
		figured it out.
ENDIT
	    print <<ENDIT;
		Meanwhile, 
		there is a <A HREF="/deckmaster/info/GenCard.html">tutorial</a>
		that might help you.  Good luck.  Send me email at
		<A HREF="mailto:tchrist\@mox.perl.com">&lt;tchrist\@mox.perl.com&gt;</a>
		if you have questions.
ENDIT
	} 
	return 0; 
    } else {
	&codedump(0) if $DEBUG;
    } 
    return 1;
}


sub plural {
    local $_ = shift;

    /([ctgpsg]h|s)$/ 	&& return "$_(es)?"	;
    s/f$//	&& return "$_(f|ve[ns])"	;

    return "${_}s?"	;
} 

sub dump_db {
    my $card;
    fork && return;
    open (TMPDB, ">/usr/tmp/MTG-Dbase.pl") || return;
    warn "BEGIN dumping to /usr/tmp/MTG-Dbase.pl\n";
    my $ofh = select TMPDB;
    print "%Card_Names = (\n";
    for $card (@MTG::HashDB::Cards) {
	print "'", tickquote($card->{name}), "' => {\n";
	my $k;
	for $k (sort keys %$card) {
	    printf "    %-12s => %s,\n", $k,
		#(($card->{$k} > 0 ||
		#$card->{$k} eq '0')
		( $card->{$k} !~ /[^\-\d.]/ && $card ne '') # no no-numeric
		    ? ($card->{$k} || "''")
		    : "'" . tickquote($card->{$k}) . "'",
	} 
	print "},\n";
    }
    print ");\n";
    close TMPDB;
    select $ofh;
    warn "DONE dumping to /usr/tmp/MTG-Dbase.pl\n";
    exit;
} 

sub tickquote {
    local $_ = shift;
    s/\\/\\\\/g;
    s/'/\\'/g;
    return $_;
} 

sub load_texts {
    print STDERR "Loading cards...\n";
    require MTG::HashDB;
    print STDERR "done.\n";
    die 'no cards' unless @MTG::HashDB::Cards;
    my $card_count = @MTG::HashDB::Cards;
    $MAX_CARDS = $card_count;

    synthesize_schema();

    print "\rTotal of $card_count distinct cards\n";
} 

sub load_cloister {
    warn "loading cloister";
    unless (open (CLOISTER, "< cloister-list.txt")) {
	warn "can't open cloister: $!";
	return;
    } 
    while (<CLOISTER>) {
	next unless /^[A-Z]/;
	chomp;
	my($card, @fields) = split /\s*,\s*/;

	for ($card) { 
	    s/Seafarer's Quay/Seafarers' Quay/;
	    s/Will-O-The-Wisp/Will-O'-The-Wisp/;
	    s/Sea Kings' Blessing/Sea King's Blessing/;
	    s/Freyalise's Winds/Freyalise's Wind/;
	    s/Aerathi Berserker/AErathi Berserker/;
	    s/Abu Ja far/Abu Ja Far/;
	}
	my $cref = $namemap{$card};
	unless (defined $cref) {
	    # warn "load_cloister: no card $card";
	    next;
	} 
	@$cref{qw!price stddev average high low change raw_n!} = @fields;
    } 
    close CLOISTER;
} 

sub init {
    $MAX_CARDS = @MTG::Descriptions::Magic_the_Gathering;
    $SCRIPT_UPDATE = localtime ( (stat(DATA))[9] || (stat($0))[9] );
    if ( `date` =~ /\s+(\S+)\s+\d{4}$/ ) {
	$SCRIPT_UPDATE .= " $1";
    } 

    STDOUT->autoflush(1);

    *MTG::Query::this = \$main::this;

    for (qw(
	caller warn die reset exit open close umask tie untie dbmopen dbmclose
	getc read print sysread syswrite send recv eof tell seek truncate
	fcntl ioctl flock socket sockpair bind connect listen accept shutdown
	getsockname getpeername lstat stat chdir chown chroot unlink chmod
	utime rename link symlink readlink mkdir rmdir opendir readdir telldir
	seekdir rewinddir closedir fork wait waitpid system exec kill getppid
	getpgrp setpgrp getpriority setpriority time tms localtime gmtime
	alarm sleep shmget shmctl shmread shmwrite msgget msgctl msgsnd msgrcv
	semget semctl semop require gethostbyname gethostbyaddr gethostent
	getnetbyname getnetbyaddr getnetent getprotobyname getprotobynumber
	getprotoent getservbyname getservbyport getservent sethostent
	setnetent setprotoent setservent endhostent endnetent endprotoent
	endservent getpwnam getpwuid getpwent setpwent endpwent getgrnam
	getgrgid getgrent setgrent endgrent getlogin
    )) {
	*{"MTG::Query::$_"} = \&::NFW;
    } 

    $^L = "\n";

    # @MTG::HashDB::Cards = ();


    %color_map = (
	'W' =>	'White',
	'G' =>	'Green',
	'U' =>	'Blue',
	'R' =>	'Red',
	'B' =>	'Black',

    );

    %color_value = (
	'Brown' =>	-3,
	'Land' =>	-3,
	'Artifact' =>	-2,
	'Arti' =>	-2,
	'Beige' =>	-2,
	''	=>	100,	# gold, like "White/Blue"
	'Gold'  =>      100,
	'White'	=>	101,
	'Green'	=>	102,
	'Red'	=>	103,
	'Blue'	=>	104,
	'Black'	=>	105,
    );

    %release_map = (
	'U'	=>	'Gathering (1E and 2E)',
	'R'	=>	'Gathering (3E)',
	'3'	=>	'Gathering (3E)',
	'4'	=>	'Gathering (4E)',
	'5'	=>	'Gathering (5E)',
	'A'	=>	'Arabian Knights',
	'V'	=>	'Visions',
	'Q'	=>	'Antiquities',
	'L'	=>	'Legends',
	'F'	=>	'Fallen Empires',

	'I'	=>	'Ice Age',
	'AL'	=>	'Alliances',
	'H'	=> 	'Homelands',

	'V' 	=> 	'Visions',
	'D'	=>	'Dark',

	'P'	=>	'Promotional',

	'W' 	=> 	'Weatherlight',
	'M' 	=>  	'Mirage',

	'T' 	=> 	'Tempest',
	'ST' 	=> 	'Stronghold',
	'S' 	=> 	'Stronghold',  # should be this one!!
    );

    %release_value = (
	'U'	=>	0,  # alpha/beta first!

	'A'	=>	1,
	'Q'	=>	2,
	'L'	=>	3,
	'D'	=>	4,
	'F'	=>	5,

	'H'	=>	6,
	'I'	=>	7,
	'AL'	=>	8,

	'M'	=>	9,
	'V'	=>	10,
	'W' 	=> 	11,

	'T' 	=> 	12,
	'ST' 	=> 	13,

	'3'	=>	100,
	'R'	=>	100,
	'4'	=>	150,
	'5'	=>	200,

	'P'	=>	1000,	# promo last

    );

sub MTG::Query::rareness {
    use strict;
    my $this = shift;
    my $rareidx = rindex($this->{rarity},"/");
    my $rarebit = substr($this->{rarity}, 1+$rareidx, 1);
    my $nextbit = substr($this->{rarity}, 2+$rareidx);
    my $order = $::rare_order{$rarebit};
    if (!defined $order) { 
	## warn "no rareness for " . $this->{name};
    }
    if (defined $nextbit and $nextbit =~ /^\d+$/) {
	;
    } else {
	$nextbit = 1;
    } 
    $order *= 100;
    $order += $nextbit;
    return $order;
}

    %sort_method = (
	'name'		=>	q{	$A->{sort_name} cmp $B->{sort_name}	},
	'text'		=>	q{	$A->{_} cmp $B->{_}	},
	'points'	=>	q{	$A->{_} <=> $B->{_}	},
	'legal'		=>	q{	$A->{_} cmp $B->{_}	},
	'flavor'	=>	q{	$A->{_} cmp $B->{_}	},
	'artist'	=>	q{	
	    substr($A->{_}, 1 + rindex($A->{_}, ' '))
		cmp 
	    substr($B->{_}, 1 + rindex($B->{_}, ' '))
		||
	    $A->{_} cmp $B->{_}	
	},

		# Was like this and cheap but accidentally made ST two chars
		#$::release_value{substr($A->{_},0,1)} 
	'release'	=>	q{	
		$::release_value{ $A->{_} =~ m{([^/]+)$} ? $1 : die "no rel" }
		    <=> 
		$::release_value{ $B->{_} =~ m{([^/]+)$} ? $1 : die "no rel" }
				},	

	'inprint'	=>	q{	
					$A->{'inprint'} <=> $B->{'inprint'} 
				},	

	'first_rarity'	=> q{
	    $rare_order{ substr( $A->{first_rarity}, 0, 1 ) }
		<=>
	    $rare_order{ substr( $A->{first_rarity}, 0, 1 ) }
		||
	    substr( $A->{first_rarity}, 1 )
		<=>
	    substr( $B->{first_rarity}, 1 )
	},

	'current_rarity'	=> q{
	    rareness($A) <=> rareness($B)
	},

	'rarity'	=> q{
	    rareness($A) <=> rareness($B)
	},

	'n_rarity'	=>	q{
	$rare_order{ substr( $A->{n_rarity}, 1+rindex($A->{n_rarity}," "), 1) }
	    <=>
	$rare_order{ substr( $B->{n_rarity}, 1+rindex($B->{n_rarity}," "), 1) }

    ||

	substr( $A->{n_rarity}, 1+rindex($A->{n_rarity}," ")) 
	    cmp
	substr( $B->{n_rarity}, 1+rindex($B->{n_rarity}," "))

    ||

	$rare_order{ substr( $A->{rarity}, 0, 1 ) }
	    <=>
	$rare_order{ substr( $A->{rarity}, 0, 1 ) }

    ||

	$A->{n_rarity}
	    cmp
	$B->{n_rarity}
},	


	'color'		=>	q{

    (
	    ( $A->{_} && $::color_value{$A->{_}} )
		||
	     $::color_value{substr($A->{'type'},0,4)}
    )
	<=>
    (
	    ($B->{_} && $::color_value{$B->{_}})
		||
	     $::color_value{substr($B->{'type'},0,4)}
    )


},

	'type'		=>	q{	$A->{_} cmp $B->{_}	},

	'metatype'		=>	
q{	
	substr($A->{'type'},0,4)
		cmp
	substr($B->{'type'},0,4)
},

	'cost'		=>	
q{	
	$A->{'ncost'} <=> $B->{'ncost'}	
		      || 
	$A->{'vcost'} <=> $B->{'vcost'}	
			||
	$A->{'cost'} cmp $B->{'cost'}	
},	 # cmp or <=> on last one?


	'powtuf'	=>	
q{	
	$A->{'power'} <=> $B->{'power'}	
			||
	$A->{'power'} cmp $B->{'power'}	
		      || 
	$A->{'toughness'} <=> $B->{'toughness'}	
			||
	$A->{'toughness'} cmp $B->{'toughness'}	
},	

	'power'		=>	q{	$A->{_} <=> $B->{_} || $A->{_} cmp $B->{_}	},
	'toughness'	=>	q{	$A->{_} <=> $B->{_} || $A->{_} cmp $B->{_}	},
	'v_rarity'	=>	q{	$A->{_} cmp $B->{_}	},
	'n_release'	=>	q{	$A->{_} cmp $B->{_}	},
	'v_release'	=>	q{	$A->{_} cmp $B->{_}	},
	'v_printrun'	=>	q{	$A->{_} cmp $B->{_}	},
	'n_printrun'	=>	q{	$A->{_} cmp $B->{_}	},
	price		=>	q{	$A->{_} <=> $B->{_}	},
	stddev		=>	q{	$A->{_} <=> $B->{_}	},
	average		=>	q{	$A->{_} <=> $B->{_}	},
	high		=>	q{	$A->{_} <=> $B->{_}	},
	low		=>	q{	$A->{_} <=> $B->{_}	},
	change		=>	q{	$A->{_} <=> $B->{_}	},
	raw_n		=>	q{	$A->{_} <=> $B->{_}	},

    ); 

    %rare_order = (
	'R'	=> 1,
	'U'	=> 2,
	'C'	=> 3,
	'L'	=> 4,
    );

}

sub cut {
    local($record, @positions) = @_;
    local($template) = '';
    local($lastpos) = 1;

    1 while $record =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;

    unless ($template = $cut'formats{"@positions"}) {
       foreach $place (@positions) {
           $template .= "A" . ($place - $lastpos) . " "; $lastpos = $place;
       }
       $template .= "A*";
       $cut'formats{"@positions"} = $template;
    }
    unpack($template, $record);
}

sub Query::sort_ordering {  $::a->{'name'} cmp $::b->{'name'} }

sub trim {
    $_[0] =~ s/^\s*(.*?)\s*$/$1/;
} 

sub user_sort {
    my $line = shift;
    trim($line);
    my @fields = split (/[\s,]+/, $line);
    $::Primary_Sort = $fields[0] || 'name';
    $::Primary_Sort =~ s/^\~//;
    local $code = "sub sort_ordering {\n";

    unless (grep /savedups/i, @fields) {
	$::Trim_Duplicates = 1;
    } else { 
	@fields = grep !/savedups/i, @fields;
	$::Trim_Duplicates = 0;
    }

    for (@fields) {
	trim($_);
	$_ = lc($_);

	my $reverse =  s/\~//;
	unless ($sort_method{$_}) {
	    # warn "$_ not a valid sort field";
	    print "</PRE><B>Sort compilation error: $_ not a valid sort field;",
			q(Probably you should try to use the <A
			HREF="/deckmaster/forms/mx-frontend.html">simple query form for
			non-programmers</a> instead.);
	    logmsg( "$_ not a valid sort field");
	    next;
	}
	my $frag = $sort_method{$_};
	$frag =~ s/\Q{_}/{'$_'}/g;
	if ($reverse) {
	    $frag =~ s/\$A/\$::b/g;
	    $frag =~ s/\$B/\$::a/g;
	} else {
	    $frag =~ s/\$A/\$::a/g;
	    $frag =~ s/\$B/\$::b/g;
	} 
	exit unless $frag;
	$code .= "	$frag	||\n";
    } 
    $code .= q[	$::a->{'name'} cmp $::b->{'name'} ];
    $code .= "\n}\n";
    $code =~ s/^\s*//;
    code_debug('Generated Sort Code', $code);

    eval "package MTG::Query; $code";
    if ($EVAL_ERROR) { 
	# print "</PRE><B>Compilation Error!<P><PRE>$EVAL_ERROR</PRE>";
	&codedump(1);
	0;
    } else {
	#$code =~ s/\s+/ /g;
	#syslog("info", "Sort Code is $code");
	1;
    } 
} 

sub code_debug {
	my ($name, $code) = @_;
	return unless $DEBUG || $R::debug;
	print <<"!DONE!WITH!THIS";
<H3>$name</H3>
    <BLOCKQUOTE>
	<PRE>
@{[ html_escape($code) ]}
	</PRE>
    </BLOCKQUOTE>
!DONE!WITH!THIS
} 

sub mungeat {
    local *_ = *@;
    s/\s\(eval\s\d+\)//g;
    s/, <.*?>( line \d+\.)?$//g;
    s/\n/<BR>/g;
    #s/at line.*?,//;
}

sub codedump {
    my $prob = @_ && $_[0];
    &mungeat;
    #print "Compilation Error!<I>$EVAL_ERROR</I><\B>\n";
    print "</PRE><B>";
    print "Compilation Error: \n" if $prob;
    print "<I><UL>";
    print $EVAL_ERROR;
    print "</B></PRE></UL></I>\n";
    logmsg( "Compilation Error: $EVAL_ERROR") if $prob;
    local $i = 0;
    $code =~ s/^/++$i . ": "/gem;
    print "<B>Code was<BR><UL><PRE>\n$code</UL></PRE></B>\n";
}

sub main::NFW { 
    logmsg( "nfw caught one");
    CORE::die "Permission denied!\n" 
} 


sub start_server {
    use strict;

    my $in_server = 0;

    $::CGI_Obj = new CGI::Base;

    if ($MXPERL_PORT) {{
       my $port = $MXPERL_PORT;
       my $proto = getprotobyname('tcp');
       socket(SERVER, PF_INET, SOCK_STREAM, $proto)        || warn "socket: $!", last;
       setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR,
					   pack("l", 1))   || warn "setsockopt: $!", last;
       umask(0);  
#Under Linux, Unix-domain sockets must be world-writable for 
#someone other than their owner to connect() to them.  Hello!?
       bind(SERVER, sockaddr_in($port, INADDR_ANY))        || warn "bind: $!", last;
       umask(02);  
       listen(SERVER,10)                            || warn "listen: $!", last;

       $in_server = 1;

       $::SERVER_SOCK = "port 2345";

    }}

    unless ($in_server) {
	if (-e $::SERVER_SOCK and not unlink $::SERVER_SOCK) {
	    die "Can't unlink old server sock $::SERVER_SOCK: $::ERRNO";
	} 

	my $uaddr = sockaddr_un($::SERVER_SOCK);
	socket(SERVER,PF_UNIX,SOCK_STREAM,0)    || die "socket $::SERVER_SOCK: $::ERRNO";
	bind  (SERVER, $uaddr)                  || die "bind $::SERVER_SOCK: $::ERRNO";
	# stupid linux won't work without this
	chmod(0777, $::SERVER_SOCK);
	listen(SERVER,5)                        || die "listen $::SERVER_SOCK: $::ERRNO";
    }

    if ($::EUID == 0) {
	if ($::BOXDIR) {
	    chdir $::BOXDIR or warn "can't chdir to $::BOXDIR: $::ERRNO";
	    chroot $::BOXDIR or warn "can't chroot to $::BOXDIR: $::ERRNO";
	} else {
	    chop($::BOXDIR = `pwd`);
	} 
	$::GID = $::EGID = $::SAFE_GID;
	$::UID = $::EUID = $::SAFE_UID;
	logmsg( "you are protected in $::BOXDIR with $::UID and $::GID");
    }

    #$SIG{'CHLD'} = sub { 
	#$waitedpid = wait;
	#logmsg( "some child exited: $waitedpid $?" );
    #};

    $::QTIME = 10; 

    set_daemon_state("accepting connections on $::SERVER_SOCK");
    logmsg("accepting connections on $::SERVER_SOCK");

    while ( accept(CLIENT,SERVER) || $::ERRNO =~ /intr/ ) {
	local $SIG{ALRM} = sub { die "Query timed out" };

	open(SAVE_IN, "<&STDIN");
	open(SAVE_OUT, ">&STDOUT");
	# open(SAVE_ERR, ">&STDERR");

	open(STDIN, "<&CLIENT")  || die "can't dup client to stdin";
	open(STDOUT, ">&CLIENT") || die "can't dup client to stdout";
	STDOUT->autoflush();

	#open(STDERR, ">&CLIENT") || die "can't dup client to stdout";

	CGI::Base::LogFile ($::LOGFILE);

	eval { 
	    handle_request();
	};

	if ($@ =~ /Query timed out/i) {
	    logmsg( "query timeout");
	    print <<EOTHING;
<HR>
<h3>Query Timeout!</h3>
</PRE>
Sorry, your query didn't complete in $::QTIME seconds!
Either the system is very heavily loaded, or something went wrong.
You should probably <A HREF="mailto:tchrist\@mox.perl.com">mail me</a>
about it.
<P>
EOTHING
	    trailer();
	} elsif ($@) {
	    print "<H1>WARNING</H1><DL><DT>Unexpected exception during request handling:<DD><CODE>$@</CODE></DL>\n";
	    logmsg( "Funny unexpected exception during request handling: $@");
	    warn $@;
	} 

	logmsg( "Done with #$::Request_No: $::Requestor");
    } continue {
	set_daemon_state("accepting connections on $::SERVER_SOCK");
	close CLIENT; 
	#close STDOUT;  CLOSE STDIN;
	#close STDERR; 
	#close STDIN;
	open(STDIN, "<&SAVE_IN") || warn "can't restore STDIN";
	open(STDOUT, ">&SAVE_OUT") || warn "can't restore STDOUT";
	# open(STDERR, ">&SAVE_ERR") || warn "can't restore STDERR";
    } 

    die "accept $::SERVER_SOCK: $::ERRNO";
}

sub handle_request {
    STDOUT->autoflush(1);
    #STDERR->autoflush(1);
    local $SIG{PIPE} = sub { die "Unexpected SIGPIPE" }; 
    # $Request_No;
    local $_;
    my $code = 'package R; reset "a-z";';
    while (<STDIN>) {
	last if /^<<EOF>>/;
	$code .= $_;
    } 
    $code =~ s/\\x([A-F0-9]{2})/chr(hex($1))/ge;
    $code =~ s/\\\(\\\)/\\/g;
    # print "Here comes the code: \n<PRE>$code</PRE>\n";
    eval $code;
    if ($@) {
	logmsg("Bad incoming request: $@");
	print "Internal Error: $@\n";
	die "Internal Error";
    } else {
	$Request_No++;
    } 
    local $SIG{PIPE} = sub { warn "Unexpected SIGPIPE, nonfatal" }; 

    $Requestor = "$R::remote <$R::login> using $R::agent from $R::origin";
    logmsg( "MTGDB req#$Request_No $Requestor ($R::debug)" );
    logmsg( "	       #$Request_No select is: $R::query");
    logmsg( "	       #$Request_No sort   is: $R::sort") if $R::sort;
    logmsg( "	       #$Request_No format is: $R::format") if $R::format;
    $R::login = '' unless defined $R::login;

=comment

    if ($R::agent =~ /Microsoft Internet Explorer/) {
	print "<H1>SORRY</H1>This database does not support your browser.  
	    I suggest you acquire something like netscape, mosaic, or lynx.\n";
	logmsg( "screw microsoft");
	return;
    } 

=cut

    set_daemon_state("servicing $Request_No" . ($R::login && "<$R::login>"));

    local $_ = $R::query;

    eval { &process_request };
    if ($@) {
	if ($@ =~ /SIGPIPE/) {
	    logmsg($@);
	} elsif ($@ =~ /Query timed out/) {
	    die;
	} else {
	    logmsg("Unknown exception: $@");
	    print "<H1>WARNING</H1><DL><DT>Unexpected exception during card selection:<DD><CODE>$@</CODE></DL>\n";
	    die;
	}
    }
} 

format DEFAULT_TOP =
@<<<<<<<<<<<<<<<<<<<<< @<<<<<<<< @<<<<<< @<<<< @<<<<< @*
{
$HEADER{"name"},
		      $HEADER{"cost"},
				 $HEADER{"powtuf"},
				      $HEADER{"release"},
					     $HEADER{"rarity"},
							$HEADER{"type"} 
}
<HR>
.

format DEFAULT =
@<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<< @<<<<<< @<<<< @<<<<< @*
{
substr($this->{"name"},0, 21) . ($this->{"name"} && "</A>"),
		          $this->{"cost"} && substr($this->{"cost"},2),
				     $this->{"powtuf"},
					      $this->{"release"},
						     $this->{"rarity"},
									    $this->{"type"},
}
.


sub set_daemon_state {
    unless ($::ProgName) { 
	($::ProgName = $0) =~ s,.*/,,;
    }
    my $state = shift;
    $0 = "$::ProgName [$state]";
} 


sub sbt {
    my $warning = $_[0];
    local $^W = 0;
    $warning =~ s/ at \(eval.*\n//;
    my $reduce = $warning;
    $reduce =~ s/".*?"//;
    warn "WARNING: $warning in card " . $MTG::Query::this->{"name"} . "\n"
	unless $warned{$reduce}++;
} 

sub synthesize_schema {

    my $this;

    my $cidx = 0;



    for $this (@MTG::HashDB::Cards) {

	local $_ = $this;

	$MTG::Query::this = $_;

	my $sname;

	printf STDERR "\r%4d", $cidx if $cidx++ % 25 == 0;
	# $cidx++;

######################################
#
# derive "v_name" from "name", then put them back around
#
######################################

	{
	    $sname = $this->{name};
	    $Card_Idx{$this->{name}} = $cidx - 1;
	    $sname =~ s/ \(.*//;
	    $Card_Idx{$sname} = $cidx - 1;
	    my $tmpname = $this->{name};
	    #$this->{name} = $sname;
	    #$this->{v_name} = $tmpname;
	    $namemap{$sname} = $this;
	    $namemap{$this->name} = $this;
	    no strict 'refs';
	    #$sname =~ s/^The //;
	    $this->{sort_name} = $sname;
	    $$sname = $this;
	    ${$this->{name}} = $this;

=unsupported

	    if (defined &typeI_banned) {
		$this->{points} = 'B';
	    } else { 
		$this->{points} = 0 + $MTG::Tourney::DC_Points{$sname};
	    } 

=cut

	}

######################################
#
# derive "legal" from tourney functions
#
######################################
	{
	    my($typeI, $typeII, $typeI_5, $typeI_75, );

	    $typeI = do {
		    if    (&classic_banned)   	{ 'B' } 
		    elsif (&classic_restricted) 	{ 'R' }
		    else 			{ 'Y' } 
	    };

	    $typeII = do {
		    if    (&standard_banned)   	{ 'B' } 
		    elsif (&standard_restricted) 	{ 'R' }
		    else 			{ 'Y' } 
	    };

	    $typeI_5  = do {
		    if    (&classicR_banned)   	{ 'B' } 
		    elsif (&classicR_restricted) { 'R' }
		    else 			{ 'Y' } 
	    };

	    $typeI_75  = do {
		    if    (&extended_banned)   	{ 'B' } 
		    elsif (&extended_restricted) { 'R' }
		    else 			{ 'Y' } 
	    };

	    $this->{legal} = join '/', $typeI, $typeII, $typeI_5, $typeI_75;
	} 


######################################
#
# derive "power" and "toughness" from "powtuf"
#
######################################


	if (length($this->{powtuf})) {
	    my ($power, $toughness) = split ( m:/:, $this->{powtuf}, 2 ) ;
	    $this->{power} = $power;
	    $this->{toughness} = $toughness;
	}

######################################
#
# clone 3E-only "release" retroactive back to UL, adjusting "rarity" also
#
######################################

	if ( $this->{release} =~ m,^3,) {
	    $this->{release} =~ s,^,U/,;
	    $this->{rarity} =~ s,^(.),$1/$1,;
	}

######################################
#
# from "cost" (like UU3) derive as follows
#
#	ncost	strictly numeric mana amount
#	rcost	this is the real cost -- we're going to prepent ncost to rcost for numeric compares!
#	vcost	virtual cost.... add 1/2 above ncost per colored mana 
#			after the first, subtract 1/2 if no color
#
#	color	Green, Blue, etc.  also Gold, but not Land or Artifact
#		do we need?  n_color	G, or UG, or WBU
#	v_color no gold, but Blue/White instead
#
######################################

	my $color;
	my %colors = ();
	my @costs = ();
	my $vcost = 0;
	my $cost = $this->{cost};
	if ($cost =~ /\D/) {
	    for (split(//, $cost)) {
		local $^W = 0;
		$vcost += $_ > 0 ? $_ : 1 if $_ ne 0;
		push(@costs, $color_map{$_} || $_);
		next unless $color_map{$_};
		$colors{ $color_map{$_} }++;
	    }
	} else {
	    $vcost = $cost;
	}

	if (%colors) {
	    $color = join('/', sort { $color_value{$::a} <=> $color_value{$::b} } keys %colors);
	}
	$this->{v_color} = $this->{color} = $color;
	if (defined $color and $color =~ m(/)) { $this->{color} = 'Gold' }

	if (!$color) {
	    $this->{color} = 'Land'     if $this->{type} =~ /^(Legendary )?Land$/;
	    $this->{color} = 'Artifact' if $this->{type} =~ /^(Legendary )?Artifact/;
	}

	#$vcost = join(' + ', @costs);
	my $ncost = $vcost;
	while ( $cost =~ /[WBURG]/g) {
	    $vcost += 0.5;
	}
	$vcost -= 0.5;
	$vcost -= 0.5 unless $cost =~ /[WBURG]/;
	if ($cost =~ s/^(\d+)//) {
	    $cost .= $1;
	}
####	disable diagnostics;
	if ($cost =~ /(\D{2,})(\d+)?/) {
	    my @costs = split //, $1;
	    my $ncost = $2;
	    $cost = join ( '', sort {
			    $color_value{$color_map{$::a}} <=> $color_value{$color_map{$::b}}
			} @costs ) . $ncost;
	}
	$cost = sprintf("%02d %s", $ncost, $cost);
####	enable diagnostics;
	$this->{cost} = $cost;
	$this->{rcost} = substr($cost,1+rindex($cost,' '));
	$this->{ncost} = $ncost;
	$this->{vcost} = $vcost;

######################################
#
# from "rarity" and "release", derive the following
#
#	rarity		leave with dups: C4/U/U
#	n_rarity	C4 U
#	v_rarity	Common 4 and Uncommon
#
#	release		leave ugly: L/4
#	n_release	LG 4E
#	v_release	Legends and Gathering (4E)
#
#	printrun	Q/3/4 C4/U/U
#	n_printrun	AQ:C4 3E,4E:U
#	v_printrun	Antiquities Common 4, Gathering (3E and 4E) Uncommon
#
######################################

	my @rr = @$this{qw[release rarity]};
	$this->{printrun} = join(' ', @rr); # release.rarity
	@$this{qw{n_rarity n_release n_printrun inprint}} = compute_printruns(0, @rr);
	@$this{qw{v_rarity v_release v_printrun inprint}} = compute_printruns(1, @rr);

	# $this->{inprint} /= 100;  # numbers are too big
	# while ( $this->{inprint} =~ s/^(\s*[+-]?\d+)(\d{3})/$1,$2/ ) { } 

	$this->{card} = join(" ", @$this{qw!text artist flavor type name!});

## first_rarity

	for ($this->{first_rarity} = $this->{rarity}) {
	    if ($this->release =~ m(^A/A)) {
		s,C(\d)/C(\d),'C' . ($1+$2),e;
	    } 
	    s,/.*,,;
	} 

    }

    printf STDERR "\n\rFINAL: %4d\n", $cidx;

######################################
#
# deal with rules anomalies
#
######################################

    foreach $kobold ( "Crimson Kobolds", "Crookshank Kobolds", "Kobolds of Kher Keep" ) {
	if (!$namemap{$kobold}) {
	    warn "missing kobold $kobold";
	    next;
	} else {
	    warn "Good kobold: $kobold";
	} 
	$MTG::Query::Cannot_Sleight{$kobold} = 1;			# idiots
	$namemap{$kobold}->{color} = "Red";
	$namemap{$kobold}->{v_color} = "Red";
    }

    foreach $card ( "Dark Heart of the Wood", "Scarwood Goblins", "Marsh Goblins" ) {
	$MTG::Query::Cannot_Sleight{$card} = 1;			# idiots
    } 

    # this is a name. we can deref names due to $$sname = $this above
    ${"Nalathni Dragon"}->{inprint} 	= 275_000;
    ${"Arena"}->{inprint} 		= 150_000;
    ${"Sewers of Estark"}->{inprint} 	= 150_000;
    ${"Windseeker Centaur"}->{inprint} 	= 100_000;
    ${"Giant Badger"}->{inprint} 	= 100_000;
    ${"Mana Crypt"}->{inprint} 		= 75_000;

    ${"Norritt"}->{inprint} 		= 2_314_500;

    for $card ( 
		  "Aurochs", "Balduvian Barbarians", "Bone Shaman",
		  "Chub Toad", "Dire Wolves", "Essence Flare", "Flygja", 
		  "Gaze of Pain", "Gorilla Pack",
		  "Prismatic Ward", "Scaled Wurm", "Word of Undoing"
		) 
    {
	$$card->{inprint} = 481_000;
    } 

    # more name derefs
    my $card;  
    for $card ( keys %MTG::Query::beta_only ) { 
	next if $card eq '1';
	my $arare = substr($$card->{rarity}, 0, 1);
	my $oldprint = $$card->{inprint};
	my $newprint;
	$newprint = $$card->{inprint} -= $MTG::PrintRuns::rarity_map{"alpha $arare"};
	print STDERR "$card inprint $oldprint -> $newprint\n";
    } 

    return if $DEBUG;

    # load_cloister();

######################################
#
# lock into place
#
######################################

    printf STDERR "Freezing...";
    for $this (@MTG::HashDB::Cards) {
	foreach $k (keys %$this) {
	    const $this->{$k};
	    # const @$this{keys %$this}, $this;
	} 
    }
    printf STDERR "done...\n";


}

__END__ ###