#!/usr/athena/bin/perl -lw
use 5.006_000;
use strict;
use integer;
use vars qw ($articles %category %dex %history $inven %known %limit
             $motd $needsave $newbooksfile %parts @parts
             $rdlnfield $restoring
             $reviewbooksfile $reviewcopy $reviewmode
             $tempfile $term );
use English;
use IO::File;
use Sys::Hostname;

use vars qw( $mitsfs );
BEGIN { *mitsfs = \q(/afs/athena.mit.edu/activity/m/mitsfs) }

use lib "$mitsfs/dexcode/lib";
use Term::ReadLine; # need to use *our* copy to get Term::ReadLine::Perl right
use Term::ReadLine::Perl;
require "shelfcodes.pl";

my @month = qw( jan feb mar apr may jun jul aug sep oct nov dec );

&init;
&rdlninit;

$_ = substr ($0, 1 + rindex($0, "/"));
/^sal/ and sales();
/^dex/ and panthercomm();
/^stat/ and dexstats();
/^inv/ and inventory();
die "Don't know what to do when invoked as `$_'.\n";


sub inv_access_file { "$mitsfs/dexcode/inventory.access" }

sub panthercomm {
  my ($motd, $x);
  my (@mainmenu, @submenu);
  my $month = (localtime)[4];

  if ($inven = -e inv_access_file) {
    grep /^\s*\Q$ENV{USER}\E\s*\n/, (new IO::File inv_access_file)->getlines()
      or die
	"\n",
	"Regular dexmaster access shut off for Inventory.\n",
	"If Inventory is over and the Dexmistress forgot to undo this,\n",
	"have the Star Chamber rm the file\n  ", inv_access_file, "\n\n";
    print "\nWelcome to Inventory processing; sure you don't want inv mode?";
  }
  lock_file("dexmaster") or exit 1;  # datadex would probably be better target

  $tempfile = "dexmaster.temp";

  $motd = "$mitsfs/dexcode/motd";
  if (-e $motd) {
    open MOTD, $motd or warn "Cannot open $motd\n";
    print <MOTD>;
    close MOTD;
  }

  @mainmenu =
      (
       ["N", "New entry", sub {
	 print "REVIEW book:" if $reviewcopy;
	 my $bk = specify("new") or return;
	 my %val = inputval() or return;
	 @$bk{ keys %val } = values %val;
	 add ($bk);
	 know ($bk);
	 review ($bk) if $reviewcopy;
	 $needsave = 1;
       }],
       ["C", "Code change", sub {
	 print "REVIEW book:" if $reviewcopy;
	 my $bk = specify() or return;
	 my $val = inputval("code") or return;
	 add ($bk, $val);
	 review ($bk) if $reviewcopy;
	 $needsave = 1;
       }],
       ["P", "Put entry into series", sub {
	 my ($bk, $val, $ser, $num);
	 $bk = specify() or return;
	 $val = inputval("series", $bk) or return;
	 unless ($val =~ /[^-@\#0-9]/) {
	   $_ = $val;
	   $val = $$bk{"series"} or
	       print "Can't use modifier $_ with no old entry" and return;
	   $val = $_ = "" if /^-$/;
	   return print "Bad modifier $_" if /-/;
	   ($val =~ tr/@//d or substr ($val, 0, 0) = "@") && tr/@//d if /@/;
	   $val =~ / ?([0-9\#,]*\Z)/;
	   ($ser, $num) = ($`, $1);
	   if (/\d/) {
	     $val = "$ser $_";
	   }
	   elsif (/\#/ && $num ne "") {
	     $num =~ tr/\#//d or substr ($num, 0, 0) = '#';
	     $val = "$ser $num";
	   }
	 }
	 rmbook ($bk);  # for the sake of tempsave'ing
	 $$bk{"series"} = $val;
	 $$bk{'notnew'} = 1;
	 add ($bk);
	 know ($bk, 'series');
	 $needsave = 1;
       }],
       ["T", "Title change", sub {
	 my ($bk, $val);
	 $bk = specify() or return;
	 $val = inputval("title", $bk) or return;
	 rmbook ($bk);
	 $$bk{"title"} = $val;
	 $$bk{'notnew'} = 1;
	 add ($bk);
	 know ($bk, 'title');
	 $needsave = 1;
       }],
       ["A", "Author change", sub {
	 my ($bk, $val);
	 $bk = specify() or return;
	 $val = inputval("author", $bk) or return;
	 rmbook ($bk);
	 $$bk{"author"} = $val;
	 $$bk{"notnew"} = 1;
	 add ($bk);
	 know ($bk, 'author');
	 $needsave = 1;
       }],
       ["R", "Review mode toggle", sub {
	 $reviewmode = !$reviewmode;
	 print "REVIEW mode ", $reviewmode ? "on" : "off";
       }],
       ["G", "Grep for pattern", sub {
	 searchfor($POSTMATCH);
       }],
       ["S", "Save", sub {
	 savedex ('main') if yesno ("Confirm raw-data save: ");
       }],
       ["M", "Message of the day", sub {
	 if (-e $motd) {
	   open MOTD, $motd or warn "Cannot open $motd\n";
	   print <MOTD>;
	   close MOTD;
	 }
	 else {
	   print "There is no current MOTD.";
	 }
       }],
       ["O", "Other (non-Panthercomm)", sub { menuloop(\@submenu); }],
       ["Q", "Quit", \&tryquit ],
       );

  @submenu =
      (
       ["R", "Restore temporarily saved changes", \&restore ],
       ["N", "Newdex (make monthly pinkdex supplements)", sub {
	  for my $mon (@month)
	    {
	      my $sup = lc "newdex-$mon";
	      if (loaddex($sup, "supple"))
		{
		  no integer;
		  my $yr = 1900 + (localtime (time - 24 * 3600 * -M $sup))[5];
		  prettydex (-which => "supple", -by => "author",
			     -tex => $sup, -supple => "\u$mon $yr Supplement");
		}
	      else
		{ print "(no $sup)" }
	    }
	}],
       ["Y", "Yeardex (make year's-new-books supplements)", \&yeardex],
       ["P", "Patchdex (make then-to-now pinkdex-changes supplement)", \&patchdex],
       ["D", "Dexes (make normal pinkdex, titledex, seriesdex)", sub {
	  my @want;
	  {
	    @want = grep { yesno("Dex by $_? ") } qw( author title series );
	    return unless @want;
	    redo unless yesno("You want to index by: @want, right? ");
	  }
	  prettydex(-by => $_, -which => "main", -letterbreaks => 1) for @want;
	}],
       ["S", "Shelfdex (make for Inventory)", sub {
	  shelfdex(-books => $dex{"main"}, -dir => "/tmp/shelfdex",
		   -boxing => 1,
		   -chunks => "shelf-chunks", -name => "shelfcode")
	}],
       ["B", "Back to main menu", sub { return "quit menu"; }],
       ["Q", "Quit", \&tryquit ],
       );

  print "Loading in datadex...";
  loaddex ('datadex', 'main') || die "Cannot open datadex";

  $newbooksfile = "newdex-$month[$month]";
  unlink $newbooksfile if -e "$newbooksfile" and -M "$newbooksfile" > 40;
  loaddex ($newbooksfile, 'new');

  loaddex ('lostdex', 'lost');

  for (6..11) {
    $x = "review-" . $month[$month - $_];
    unlink $x if -e "$x";
  }
  $reviewbooksfile = "review-$month[$month]";
  loaddex ($reviewbooksfile, "review");
  $reviewmode = 0;

  menuloop(\@mainmenu, sub { $reviewcopy = $reviewmode || /^(N|C)R$/; });

  die "Got past the main menu loop somehow";
}

sub lock_file
  {
    our %lock;
    my $file = shift or die;
    exists $lock{$file} and print "$file is already locked" and return undef;
    my $lockfile = "$file.lock";
    my $stamp = join " ", scalar(localtime), $ENV{USER}, hostname(), $PID;
    my $mask = umask;
    umask(0333);
    if (my $wr = new IO::File $lockfile, "w")
      { $wr->print($stamp); $wr->close() }
    umask $mask;
    my $rd = new IO::File $lockfile or die "can't read $lockfile back in";
    chomp(my $owner = $rd->getline());
    $owner eq $stamp or print "$lockfile taken:\n\t$owner" and return undef;
    $lock{$file} = $lockfile;
    return 1;
  }
sub unlock_file
  {
    our %lock;
    my $file = shift or die;
    die "don't have $file locked" unless exists $lock{$file};
    unlink $lock{$file} or die "unable to unlink $lock{$file}";
    delete $lock{$file};
  }
sub unlock_all
  {
    our %lock;
    unlock_file($_) for keys %lock;
  }


sub menuloop {
  my @specs = @{shift @_};
  my $eachtime = shift;
  my @choices;
  my %menu;

  foreach (@specs) {
    push @choices, "$$_[0]) $$_[1]";
    $menu{$$_[0]} = $$_[2];
  }

  {
    print join "\n", "", @choices;
    $_ = rdlnget("option: ") or redo;
    &{$eachtime} if $eachtime;
    /^(.)/;
    $_ = ($menu{$1} ? &{$menu{$1}} : print "That is not an option.")
      or redo;
    redo unless /quit menu/;
  }
}


# by default, match (non-new) author/title from surface;
# "-PARTIAL" depth-matches "PARTIAL"
# returns book for success, false for failure;
# the false will be undef iff the user didn't give enough to _try_ to specify
sub specify {
  my $isnew = @_;
  my ($bk, @poss, $n, $eval);

  ($$bk{'author'} = inputval ('author')) or ($isnew && return undef);
  ($$bk{'title'} = inputval ('title')) or ($isnew && return undef);

  return undef unless length $$bk{'author'} or length $$bk{'title'};

  if ($isnew) {
    $$bk{'series'} = "";
    placefields ($bk);
    my $old = findbook (-find => $bk, -which => "main")
      or return $bk;
    print "That's not new!  We already have $old->{'code'}";
    return 0;
  }

  # "title and author" is often faster to fail than "author and title"
  $eval = '@poss = grep { ';
  $eval .= sprintf('$_->{title} =~ /%s/',
		   (($$bk{'title'} =~ /^- ?/)  ? "\Q$'" : "^\Q$$bk{'title'}"))
      if $$bk{'title'};
  $eval .= ' and ' if $$bk{'author'} and $$bk{'title'};
  $eval .= sprintf('$_->{author} =~ /%s/',
		   (($$bk{'author'} =~ /^- ?/) ? "\Q$'" : "^\Q$$bk{'author'}"))
      if $$bk{'author'};
  $eval .= ' } @{$dex{"main"}}';
  eval $eval;

  @poss or print "That is not in the database." and return 0;
  @poss > 20 and print "Too many matches. Be more specific." and return 0;

  if (@poss > 1) {
    print "0) abort";
    $n = 0;
    print "$n) ", panther($poss[$n-1]) until ++$n > @poss;
    $n = rdlnget("? ") or return 0;
  }
  else {
    $n = 1;
  }
  return 0 unless $n > 0 && $n <= @poss;
  print "Selection ", panther($poss[$n-1]);
  return $poss[$n-1];
}



# called with no args ---> ask for every *non-key* field, no defaults
# called with one arg --> ask for that field, no default
# called with two args --> first says field, 2nd says book for default
sub inputval {
  my $field = shift;
  my $bk = shift;
  my (%val, $prompt, $cat, @bad);

  unless ($field) {
    $val{'series'} = inputval ('series');
    $val{'code'} = inputval ('code') or return ();
    return %val;
  }

  $field = lc $field;
  $prompt = ucfirst "$field:  ";

  $_ = $bk ? $$bk{$field} : undef;
 BLOCK: {
    $_ = rdlnget ($prompt, -default => $_, -field => $field)
      or return "";
    if (@bad = /<|>|{|}|\^|\\/g) {
      print "Illegal character(s): @bad";
      redo BLOCK;
    }
    if (/[\000-\037]/) {  # though i think rdlnget never returns any anyway...
      print "Control characters are illegal.";
      redo BLOCK;
    }
    # field-dependent checks
    if ($field eq "author") {
      s/\.(?![ .,|]|\Z)/. /g;
      last BLOCK;
    }
    if ($field eq "code") {
      tr/; /:/d;
      last BLOCK;
    }
    if ($field eq "title") {
      if (tr/=// > 1) {
	print ("Only one placement title is allowed.");
	redo BLOCK;
      }
    }
    if ($field eq "series") {
      # no spaces in "#1,2,3" part
      1 while s/( [0-9\#,]+) (?=[0-9\#,]*(\Z|\|))/$1/g;
      # a series name should not itself start with "@"
      /^@@/ and print "May not have multiple leading \@s." and redo BLOCK;
      /\|@/ and print "May only be \@ first series." and redo BLOCK;
      # random @s in the name are allowed ("b@nking") but likely mistakes
      /.@/ and (yesno("Do you really want an '\@' as part of the series name?")
		or redo BLOCK);
      # better not have multiple #s, or any after |s
      /(\#|\|).*\#/ and print "Bad #s" and redo BLOCK;
      # check they didn't put in a shelfcode by mistake
      grep { not exists $category{basecode((split /[:;]/)[0]) } } split /, ?/
	or yesno("That looks like a shelfcode.  Do you really mean it? ")
	  or redo BLOCK;
      /=/ and (yesno("Do you really want an '=' as part of the series name?")
	       or redo BLOCK);
    }
    if ($field =~ /title|series/) {
      /^$articles /o
	and (yesno("Do you really want to start with an article? ")
	     or redo BLOCK);
      /[][]/ and (yesno("Do you really want those brackets? ")
		  or redo BLOCK);
    }
  }
   ;  # semantically empty but makes emacs indentation happy

  if (/\S/) {
    my $line = $_;
    @{$history{$field}} = grep { $_ ne $line } @{$history{$field}};
    push @{$history{$field}}, $line;
  }

  return $_;
}


sub findbook {         # should have place* set already!
  my %opt = @_;
  my $bk = $opt{-find} or die;
  my $list = $opt{-books} || $dex{$opt{-which}} or die;
  my ($plauthor, $pltitle) = @$bk{qw(placeauthor placetitle)};
  my ($reauthor, $retitle) = @$bk{qw(author title)};

  my $n;
  # start at the end, go up
  $n = $#$list unless defined ($n = $opt{-start}) and $n <= $#$list;
  # this will probably be sort of inefficient;
  # switch to binary search, maybe...
  --$n while ($n >= 0 and ($$list[$n]{'placeauthor'} cmp $plauthor) > 0);
  --$n while ($n >= 0
	      and $$list[$n]{'placeauthor'} eq $plauthor
	      and ($$list[$n]{'placetitle'} cmp $pltitle) > 0);
  --$n while ($n >= 0
	      and $$list[$n]{placeauthor} eq $plauthor
	      and $$list[$n]{placetitle} eq $pltitle
	      and ($$list[$n]{author} cmp $reauthor) > 0);
  --$n while ($n >= 0
	      and $$list[$n]{author} eq $reauthor # real authors match now
	      and $$list[$n]{placetitle} eq $pltitle
	      and ($$list[$n]{title} cmp $retitle) > 0);

  my $match = ($n >= 0
	       and $$list[$n]{author} eq $reauthor
	       and $$list[$n]{title} eq $retitle
	       and $$list[$n]);
  return $match unless wantarray;
  return ($match, ($match ? $n : $n+1));  # first one that $bk *precedes*
}


sub rmbook {
  my $bk = shift;
  my $which = shift || 'main';
  my $failsafe = shift || undef;
  my ($junk, $n) = findbook (-find => $bk, -which => $which);
  if ($junk)
    {
      splice @{$dex{$which}}, $n, 1;
      tempsave ($bk, $$bk{'code'}, "") if $which eq 'main';
    }
  elsif (not $failsafe)
    { die "rmbook book not found!  serious problem!\n" }
}


sub add {
  my $bk = shift;
  my $val = shift;
  my $which = shift || 'main';
  my $talk = shift;
  defined $talk or $talk = $which =~ /\A(main|lost|sale)\Z/;
  my $note = ($which eq 'main' ? "" : "($which)");

  if ($val) {
    my $old = { %$bk };
    my (%old, %new, $owned);

    $owned = ($which eq 'main') && (wehave($bk) > 0);
    %old = codetohash ($$bk{'code'});
    %new = codetohash ($val);
    for (keys %old) {
      ($new{$_} ||= 0) += $old{$_}
    }
    $$bk{'code'} = hashtocode (%new);

    if ($$bk{'code'} eq "") {
      rmbook ($old, $which);
      print $note, "Deleted!" if $talk;
    }
    elsif ($which eq 'main') {
      tempsave ($bk, $$old{'code'}, $$bk{'code'});
      print $note, "Changed to ", panther($bk) if $talk;
    }
    add ($old, undef, 'lost', $talk) if $owned && (wehave($bk) <= 0) &&
	($inven || yesno("We no longer own any copies; place in lostdex? "));
  }
  else {
    # these will often, but not always, be properly set already
    placefields ($bk);
    my ($cur, $n) = findbook (-find => $bk, -which => $which);
    if ($cur) {
      if ($talk) {
	print $note, "Merging    ", panther($bk);
	print $note, "with       ", panther($cur);
      }
      add ($cur, $$bk{'code'}, $which, $talk);
    }
    else {
      $$bk{'code'} = hashtocode (codetohash ($$bk{'code'})) or
	  return print "No valid shelfcode; ignoring entry.";
      splice (@{$dex{$which}}, $n, 0, $bk);
      if ($which eq 'main') {
	tempsave ($bk, "", $$bk{'code'});
	add ({%$bk}, undef, 'new') unless exists $$bk{'notnew'};
      }
      # outside responsible for know()ing
      print $note, "Entry is ", panther($bk) if $talk;
    }
  }
}

sub codetohash {
  my $code = shift;
  my (%table);

  foreach (split /,/, $code) {
    my ($cat, $n) = split /[:;]/, "$_:1";
    $table{$cat} = $n;
  }

  return %table;
}

sub sum_hashes
  {
    my %sum;
    for my $hash (@_)
      { ($sum{$_} ||= 0) += $$hash{$_} or delete $sum{$_} for keys %$hash }
    return \%sum;
  }

sub sum_metahashes
  {
    my %keys = map { %$_ } @_;
    my %sum = map {
      my $key = $_;
      $key => sum_hashes(map { $$_{$key} } grep { exists $$_{$key} } @_)
    } keys %keys;
    keys %{$sum{$_}} or delete $sum{$_} for keys %sum;
    return \%sum;
  }


sub improper_shelfcode
  {
    die if @_ != 1;
    my $bc = basecode($_[0]);
    return "no such shelfcode '$bc'" unless exists $category{$bc};
    return "double shelfcode '$bc' needs numerical suffix"
	if $category{$bc}{"doub"} and $_[0] !~ /\d\Z/;
    return ();
  }
# %category from shelfcodes.pl
sub hashtocode {
  my %hash = @_;
  my $keep;

  return join ',', map {
    my $bc = basecode ($_);
    if (exists $category{$bc}) {
      if ($category{$bc}{'doub'} and !/\d$/) {
	print "Double shelfcode $_ lacks terminating digit(s); ignoring.";
	();
      }
      else {
	$keep = $category{$bc}{'keep'};
	if ($hash{$_} > $keep and $limit{"max"}) {
	  print "$hash{$_} is too many $_.  Lowering to $keep.";
	  $hash{$_} = $keep;
	}
	if ($hash{$_} < 0 and $limit{"min"}) {
	  print "$_:$hash{$_} being treated as nothing.";
	  ();
	}
	elsif (not $hash{$_}) {
	  ();
	}
	else {
	  $hash{$_} != 1 ? "$_:$hash{$_}" : "$_";
	}
      }
    }
    else {
      print "Improper shelfcode:  $_.  Ignoring.";
      ();
    }
  } sort keys %hash;
}
sub hashtocode_nocheck
  {
    join ',', map { join ":",
		    grep { $_ ne "1" } $_, $_[0]{$_}
		  } sort keys %{$_[0]};
  }


sub rdlninit {
  my ($package) = caller;
  $ENV{"PERL_READLINE_NOWARN"} = 1;
  $ENV{"PERL_RL"} ||= "Perl o=0";
  $term = new Term::ReadLine 'dexmaster';
  $readline::rl_completion_function = "${package}::rdlncomplete";
  $readline::rl_basic_word_break_characters = '@|';
  $readline::rl_completer_word_break_characters = '@|';
  undef $rdlnfield
    # silence "used only once, possible typo" warnings
    and $readline::rl_completion_function
      and $readline::rl_basic_word_break_characters
	and $readline::rl_completer_word_break_characters;
}

sub rdlncomplete {
  my $text = uc shift;
  my $pat = quotemeta $text;
  # ignore ($line, $start) args

  return unless exists $known{$rdlnfield};
  $text =~ /^$pat/;
  $readline::rl_completer_terminator_character = '';
  return grep //, @{$known{$rdlnfield}};
  # silence "used only once, possible typo" warning
  $readline::rl_completer_terminator_character;
}

sub know {
  my $bk = shift;
  my @fields = @_ ? @_ : qw(author title series);
  my ($f, $k);

  foreach $f (@fields) {
    foreach $k (split /\|/, $$bk{$f}) {
      my $n = grep { $_ lt $k } @{$known{$f}};  # is this reasonably fast?
      splice @{$known{$f}}, $n, 0, $k unless $known{$f}[$n] eq $k;
    }
  }
}

sub rdlnget {
  my $prompt = shift;
  my %opt = @_;

  if (defined (my $field = $opt{-field})) {
    $history{$field} = [] unless exists $history{$field};
    $term->SetHistory (@{$history{$field}});  # may want to keep only N
    $rdlnfield = $field;
  }

  while (1) {
    my $text = $term->readline ($prompt, $opt{-default});
    if (my ($command) = $text =~ /^\s*!(.*)/) {
      system ($ENV{'SHELL'}, "-c", $command);
      redo;
    }
    $text = happyline($text) unless $opt{-noedit};
    $text =~ /\S/ or not $opt{-cont} or redo;
    return $text;
  }
}


sub happyline {
  my $line = uc shift;
  $line =~ s/\s+/ /g;
  $line =~ s/\A\s|\s\Z//g;
  $line =~ s/ ([=|,])/$1/g;
  $line =~ s/([=|]) /$1/g;
  $line =~ s/,(\S)/, $1/g;
  return $line;
}


sub yesno {
  my $prompt = shift;

  while (1) {
    local $_ = rdlnget ($prompt) or redo;
    return 1 if (/^Y$/ || /^YES$/);
    return 0 if (/^N$/ || /^NO$/);
  }
}


sub placefields {
  my $bk = shift;

  $$bk{'placeauthor'} = (split /\|/, $$bk{'author'})[0];
  $$bk{'placetitle'} = (split /=/, (split /\|/, $$bk{'title'})[0])[-1];
  $$bk{'placeseries'} = (split /\|/, $$bk{'series'})[0] || "";

  $$bk{'placeseries'} =~ s/ [0-9,]+$//;  # numbers only matter with #s
  foreach (@$bk{qw(placeauthor placetitle placeseries)}) { &editplacefield }
}

sub editplacefield {   # the same manipulations should be done in &prettydex
  s/, $articles\Z//o;
  tr(-/,: )( )s;
  tr/A-Z0-9() //dc;
  s/^\(//;
  $_ .= " $1" if s/^(\d\S+) ?//;
  s/^ //;
  s/(\d+)/sprintf("%06d",$1)/ge;   # zero-pad numbers so cmp is a good sort
  s/\(/</g, s/\)/>/g;  # want them sorted _after_ digits though before letters
}


# assumes dex is in order, capitalized, etc, already!
# assumes 'main' dex is loaded only once
sub loaddex {
  my $file = shift;
  my $which = shift || 'main';
  my $main = ($which eq 'main');
  my @parts = @{$parts{$which}};
  my (%author, %title, %series);
  local *FILE;

  open FILE, $file or $dex{$which} = [] and return undef;
  $dex{$which} = [ map {
    my %bk;

    chomp;
    @bk{ @parts } = split /</, $_, -1;
    placefields (\%bk);

    if ($main) {
      undef @author{ split /\|/, $bk{'author'} };
      undef @title{  split /\|/, $bk{'title'}  };
      undef @series{ map { tr/@//d; s/ [0-9\#,]+\Z//; $_ }
		     split /\|/, $bk{'series'} } if $bk{'series'};
    }

    \%bk;
  } <FILE> ];
  close FILE;
  pop @{$dex{$which}} while   # get rid of trailing empty lines and <<<s
      $dex{$which}[-1] and !length $dex{$which}[-1]{'author'};
  $dex{$which} = [] unless @{$dex{$which}};

  if ($main) {
    $known{'author'} = [ sort keys %author ];
    $known{'title'} =  [ sort keys %title  ];
    $known{'series'} = [ sort keys %series ];
  }

  return $dex{$which};
}


sub savedex {    # datadex-format stuff only
  my $which = shift || "main";
  my %file = (
	      "main" => "datadex.tmp",
	      "new" => $newbooksfile,
	      "review" => $reviewbooksfile,
	      "lost" => "lostdex",
	      "sale" => "saledex",
	     );
  my $file = $file{$which} or return warn "Don't know how to save $which";

  print "Writing $file";
  my $out = new IO::File $file, "w"
    or return warn "Error $! opening $file for output";
  for my $bk (@{$dex{$which}})
    { $out->print(panther($bk)) }
  $out->close();

  $needsave = 0 if $which eq "main" or $which eq "sale";

  if ($which eq "main")
    {
      (my $timesuffix = scalar localtime) =~ s/ /_/g;
      print "Making diffs";
      `diff $file datadex > back.$timesuffix`;
      `diff datadex $file > forw.$timesuffix`;
      `chmod 400 back.$timesuffix forw.$timesuffix`;
      print "Moving $file in";
      rename $file, "datadex" or die;
      savedex ("new");
      savedex ("review");
      savedex ("lost");
      unlink $tempfile;
    }
}

sub book_per_field_part
  {
    my ($list, $field) = @_;
    return
      [ map
	{
	  my $bk = $_;
	  map
	    {
	      s/^.*=// if $field eq "title";
	      my %new = %$bk;
	      $new{"sortunder"} = $_;
	      &editplacefield;
	      $new{"place$field"} = $_;
	      (\%new)
	    }
	      split '\|', $$bk{$field};
	}
	@$list
      ];
  }

sub normaldex_tex_start
  {
    my %opt = @_;
    return (
	    "\\def\\dexname{\u$opt{-name}}",
	    ($opt{-by} eq "author" ? () : "\\def\\Reverse{}"),
	    ($opt{-supple} ? "\\def\\Supple{$opt{-supple}}" : ()),
	    "\\input $mitsfs/dexcode/dextex-current.tex",
	    "");
  }

sub series_summary_tex
  {
    my $list = shift or die;
    my $series = "";
    my ($author, $count);
    my @tex = "\\beginserieslist";
    for my $bk (@$list)
      {
	$_ = $$bk{"sortunder"};  # do some of &editplacefield on this
	s/^@//;
	s/ [-.0-9\#,]+\Z//;        # series-list-specific
	s/,/\,/g;    # tex header will make backslashed commas bad breakpoints
	s/([&\$%\#_])/\\$1/g;      # escape TeX special chars (but not tilde!)
	if ($_ eq $series)
	  {
	    ++$count;
	    $author eq $$bk{"author"} or $author = "authorship varies";
	  }
	else
	  {
	    push @tex, "\t\\Series{$series}{$author}{$count}"
	      if length $series;
	    $series = $_;
	    $author = $$bk{"author"};
	    $count = 1;
	  }
      }
    push @tex, "\\endserieslist";
    return \@tex;
  }

sub prettydex {    # non-datadex-format:  pinkdex, titledex, etc
  my %opt = @_;

  # -which = "main", "supple", "year", "patch", etc
  # -books = $dex{"main"} or equivalent \@books
  die unless $opt{-which} xor $opt{-books};
  $opt{-books} ||= $dex{$opt{-which}} || die;
  delete $opt{-which};

  (my $dexname = $opt{-by}."dex") =~ s/author/pink/;
  my $tex = $opt{-tex} || $dexname;
  $tex .= ".tex" unless $tex =~ /\.tex\Z/;
  delete $opt{-tex};

  # optional; "Aug 2001" etc, tex will use in headers instead of \today
  my $supp = $opt{-supple} || "";
  delete $opt{-supple};

  print scalar localtime, " beginning $dexname $supp";

  my $letterbreakson = $opt{-letterbreaks} && "place".$opt{-by};
  delete $opt{-letterbreaks};

  my $bklist = prettydex_books (%opt, -verbose => 1);

  my $file = "/tmp/$tex";
  print scalar localtime, "\t... writing $file";
  my $wr = new IO::File $file, "w" or return warn "can't write to $file";

  $wr->print($_) for normaldex_tex_start
    (-name => $dexname, -by => $opt{-by}, -supple => $supp);

  if ($opt{-by} eq "series" and not length $supp)
    {
      $wr->print($_) for @{ series_summary_tex($bklist) };
      print scalar localtime, " \t... intro list done";
    }

  my $texlist = prettydex_books_tex ($bklist);
  if ($letterbreakson)
    {
      my $letter = 'A';
      for my $entry (@$texlist)
	{
	  # assume that each of A-Z occurs, so just increment $letter
	  $$entry{-book}{$letterbreakson} !~ /^$letter/
	    and $wr->print('\NextLetter')
	      and ++$letter;
	  $wr->print($$entry{-tex});
	}
    }
  else
    { $wr->print($$_{-tex}) for @$texlist }

  $wr->print("\n\\vfill \\eject \\bye");
  $wr->close();
  print scalar localtime," \t... finished making $file";
}

sub prettydex_books {
  my %opt = @_;
  {
    my %unknown = %opt;
    delete @unknown{ qw( -books -by -nocodes -nomulti -verbose ) };
    die join " ", keys %unknown if %unknown;
  }
  die unless $opt{-books};

  (my $by = $opt{-by}) =~ /\A(author|title|series)\Z/ or die $opt{-by};
  my $placeby = "place".$by;
  my ($thenby) = grep { $_ ne $placeby } qw( placetitle placeauthor );

  my $list =
soften_dex (
    $opt{-nomulti}
      ? [ map { {%$_} } @{$opt{-books}} ]
	  : book_per_field_part($opt{-books}, $by)
);
  print scalar localtime, " \t... list generated" if $opt{-verbose};

  @$list = sort
    { $$a{$placeby} cmp $$b{$placeby} or $$a{$thenby} cmp $$b{$thenby} }
      @$list;

  if ($opt{-nocodes})
    { $$_{"code"} = "" for @$list }
  print scalar localtime, " \t... list sorted" if $opt{-verbose};

  return $list;
}

sub prettydex_books_tex {
  my $list = shift or die;
  return
    [ map
      {
	# backslash some chars in some places so our tex header can play w them
	# won't break on commas in series,
	(my $series = $$_{'series'}) =~ s/,/\\,/g;
	# nor colons in shelfcodes
	(my $code = $$_{'code'}) =~ s/:/\\:/g;
	my @arg = ($$_{"author"}, nicetitle($$_{"title"}, $series), $code);
	# escape TeX special chars (but not tilde!)
	s/([&\$%\#_])/\\$1/g for @arg;
	({ -book => $_, -tex => join ("", '\Book', map { "{$_}" } @arg) });
      }
      @$list
    ];
}

sub multilist_prettydex
  {
    my %opt = @_;
    die if $opt{-books} or $opt{-which};

    my %param;
    for my $param (qw( -lists -dexname -filehandle ))
      {
	$param{$param} = $opt{$param};
	delete $opt{$param};
      }
    my $wr = $param{-filehandle};

    $wr->print($_) for normaldex_tex_start
      (-name => $param{-dexname}, -by => $opt{-by}, -supple => "Experimental");

    for my $list (sort keys %{$param{-lists}})
      {
	$wr->print("\\hskip-1cm {\\bf $list}\\par");
	$wr->print($$_{-tex}) for
	  @{ prettydex_books_tex ($param{-lists}->{$list}) };
	$wr->print('\Setbreak');
      }

    $wr->print("\n\\vfill \\eject \\bye");
  }

sub datadex_order
  {
    my $set = shift;  # unordered, but items must still be unique
    my @list;         # ordered
    for my $bk (@$set)
      {
	my (undef, $n) = findbook (-books => \@list, -find => $bk);
	splice @list, $n, 0, $bk;
      }
    return \@list;
  }

sub shelfdex_boxing_desc
  {
    our @answer = do
      {
	my (%mayshelve, %maybox);
	while (my ($cat, $hash) = each %category)
	  {
	    if (!$$hash{"box"} or $$hash{"box"} =~ /\A(cabinet|(d?reserve))\Z/)
	      { undef $mayshelve{$cat} }
	    elsif ($$hash{"box"} eq "all")
	      { undef $maybox{$cat} }
	    else
	      { undef $maybox{$cat}; undef $mayshelve{$cat} }
	  }
	(\%mayshelve, \%maybox);
      }
    unless @answer;
    return @answer;
  }

sub shelfdex_boxing  # preserves ordering
  {
    my $allbks = shift or die;
    my %prop = map { $_ => $category{$_}{"box"} || "" } keys %category;
    my (@out, @in);
    for my $bk (@$allbks)
      {
	my %x = %$bk;
	my %c = codetohash($x{"code"});
	my %bc = map { $_ => basecode($_) } keys %c;
	my %boxing = map { $prop{$_} => 1 } values %bc;
	my (%out, %in);
	for my $c (keys %c)
	  {
	    # start with all unboxed
	    $out{$c} = $c{$c};
	    my $how = $category{$bc{$c}}{"box"}
	      or next;
	    if (
		($how eq "all") or
		($how eq "random" and not exists $boxing{"cabinet"}) or
		($how eq "dsfwa" and exists $boxing{"dreserve"}) or
		( ($how eq "sfwa" or $how eq "sfwap")
		  and exists $boxing{"reserve"} ) or
		($how eq "sfwap" and exists $boxing{"sfwa"})
	       )
	      { # move all into boxes
		$in{$c} = $out{$c};
		delete $out{$c};
	      }
	    elsif (grep { $_ eq $how }
		   qw( sfwa sfwap dsfwa random ))
	      { # move all but one into boxes
		$in{$c} = $out{$c} - 1 if $out{$c} > 1;
		$out{$c} = 1;
	      }
	  }
	delete $x{"code"};
	push @out, { %x, "code" => hashtocode_nocheck(\%out) } if %out;
	push @in,  { %x, "code" => hashtocode_nocheck(\%in)  } if %in;
      }
    return (\@out, \@in);
  }



sub shelfdex_split_cats  # preserves ordering
  {
    my $bks = shift or die;
    my %cat;
    for my $bk (@$bks)
      {
	my %code = codetohash($$bk{"code"});
	for my $code (keys %code)
	  {
	    my $bc = basecode($code);
	    my %copy = %$bk;
	    $copy{"code"} = $code;
	    $copy{"n"} = $code{$code};
	    push @{$cat{$bc}}, \%copy;
	  }
      }
    return \%cat;
  }

sub shelfdex_sort
  {
    my $raw = shift or die;
    ref $raw eq "HASH" or die ref $raw;
    my %ordered;
    for my $cat (keys %$raw)
      {
	my $bks = $$raw{$cat};
	my @tosort;
	if ($cat eq "FPR")
	  {
	    @tosort = map {  # placeseries should suffice
	      [ $_, $$_{"placeseries"}, $$_{"placeauthor"}, $$_{"placetitle"} ]
	    } @$bks
	  }
	elsif ($category{$cat}{"doub"})
	  {
	    @tosort = map {
	      (my $code = $$_{"code"}) =~ s/(\d+)/sprintf("%06d",$1)/ge;
	      [ $_, $code, $$_{"placetitle"} ]
	    } @$bks;
	  }
	else # usual case
	  {
	    @tosort = map {
	      my @byseries = $$_{"placeseries"}
		if $$_{"series"} =~ /^@/ or $$_{"code"} =~ /^@/;
	      [ $_, $$_{"placeauthor"}, @byseries, $$_{"placetitle"}, "" ]
	    } @$bks;
	  }
	$ordered{$cat} =
	  [
	   map { $$_[0] }
	   sort { $$a[1] cmp $$b[1] or $$a[2] cmp $$b[2] or $$a[3] cmp $$b[3]
		    or $$a[0]{"title"} cmp $$b[0]{"title"}
		      or $$a[0]{"author"} cmp $$b[0]{"author"} }
	   @tosort
	  ];
      }
    return \%ordered;
  }

sub shelfdex_tex_start
  {
    my %opt = @_;
    my $name = $opt{"-name"} or die;
    my $duplex = $opt{"-duplex"} ? "true" : "false";
    my $shelf = $opt{"-shelf"} || 3;
    return (
	    "\\special{! << /Duplex $duplex >> setpagedevice}",
	    "\\def\\dexname{Shelfdex: $name}",
	    "\\def\\Shelf{$shelf}",
	    "\\def\\Reverse{}",
	    ($opt{-chunks} ? "\\def\\chunk{}" : ()),
	    "\\input $mitsfs/dexcode/dextex-current.tex",
	    ""
	   );
  }
sub shelfdex_tex_finish
  { return ("", "\\vfill \\eject \\bye") }

sub shelfdex_chunks
  {
    # $catlists should be a hash of shelfcode -> [ datadex-ordered books ]
    my $catlists = shift or die;
    my $file = shift or die;
    -e $file or print "no shelf chunks file '$file'" and return undef;
    my $list = datadex_order
      (loaddex ($file, "temp") or die "failed loading $file");
    my $start = undef;
    my %start = map { $_ => undef } keys %$catlists;
    for my $bk (reverse @$list)
      {
	my $match;
	($match, $start) = findbook (-find => $bk, -which => "main",
				     -start => $start);
	$match or die "'$file' chunk @{[&panther($bk)]} not in datadex\n";
	my %hash = codetohash($$bk{"code"});
	for my $cat (map { basecode($_) } keys %hash)
	  {
	    next unless exists $$catlists{$cat};
	    my ($cur, $n) = findbook (-find => $bk, -books => $$catlists{$cat},
				      -start => $start{$cat});
	    $start{$cat} = $n;
	    $cur or $n-- or next;
	    undef $$catlists{$cat}[$n]{"chunk"};
	  }
      }
    return 1;
  }

sub shelfdex_munge_doubles
  {
    my $catslist = shift or die;
    # that must be hash of shelfcode => [ books in shelfdex_sort order ]
    for my $cat (keys %$catslist)
      {
	next unless $category{$cat}{"doub"};
	$$_{"title"} = "$$_{code} : $$_{title}" for @{$$catslist{$cat}};
      }
    # and, taking advantage of being in shelfdex order now,
    if (exists $$catslist{"GN"})
      {
	my $prev = 0;
	for my $bk (@{$$catslist{"GN"}})
	  {
	    my ($n) = $$bk{"code"} =~ /GN(\d+)/;
	    undef $$bk{"prebreak"} if $n != $prev or !$n;
	    $prev = $n;
	  }
      }
  }

sub books_to_shelfdex_tex
  {
    my %opt = @_;
    exists $opt{-books} or die;
    {
      my %unknown = %opt;
      delete @unknown{ qw( -books -chunk -prebreak ) };
      %unknown and die join " ", keys %unknown;
    }
    my @lines;
    for my $bk (@{$opt{-books}})
      {
	(my $series = $$bk{"series"}) =~ s/,/\\,/g;
	my $tex = join '', '\Book', (map { "{$_}" }
				     $$bk{"author"},
				     nicetitle($$bk{"title"}, $series),
				     $$bk{"n"});
	$tex =~ s{([&\$%\#_])}{\\$1}g;
	push @lines, '\Setbreak' if $opt{-prebreak} && exists $$bk{"prebreak"};
	push @lines, $tex;
	push @lines, '\chunk' if $opt{-chunk} && exists $$bk{"chunk"};
      }
    return \@lines;
  }

sub shelfdex
  {
    my %opt = @_;
    {
      my %unknown = %opt;
      delete @unknown{ qw( -books -boxing -chunks -dir -name ) };
      die join " ", keys %unknown if %unknown;
    }
    my $dir = $opt{-dir} or die;
    my $name = $opt{-name} or die;
    my $bklist = $opt{-books} or die;
    exists $opt{-boxing} or die;

    -d $dir and $dir =~ m(^/tmp/.+) and `rm -rf $dir`;
    mkdir $dir or return print "unable to make $dir";
    { new IO::File "$dir/test", "w" or return print "unable to write in $dir" }
    unlink "$dir/test";

    my ($shelfbks, $boxbks);
    if ($opt{-boxing})
      {
	print scalar localtime, " splitting boxed and unboxed books";
	($shelfbks, $boxbks) = shelfdex_boxing ($bklist);
      }
    else
      { $shelfbks = $bklist; $boxbks = [] }

    print scalar localtime, " forming lists by category";
    my $shelfcats = shelfdex_split_cats ($shelfbks);
    my $boxcats = shelfdex_split_cats ($boxbks);
    if ($opt{-boxing})
      {
	my ($mayshelf, $maybox) = shelfdex_boxing_desc();
	die "shelving supposedly unshelvable $_"
	    for grep { not exists $$mayshelf{$_} } keys %$shelfcats;
	die "boxing supposedly unboxable $_"
	    for grep { not exists $$maybox{$_} } keys %$boxcats;
      }

    # the $shelfcats lists have inherited *datadex* ordering
    # which is what we want for shelf chunk marking
    if (my $chunkfile = $opt{-chunks})
      {
	print scalar localtime, " loading shelf chunks from $chunkfile";
	$opt{-chunks} = shelfdex_chunks ($shelfcats, $chunkfile);# not $boxcats
      }

    print scalar localtime, " shelf-sorting lists"; # now we lose datadex order
    $_ = shelfdex_sort ($_) for ($shelfcats, $boxcats);

    print scalar localtime, " munging doubles";
    shelfdex_munge_doubles ($shelfcats);
    shelfdex_munge_doubles ($boxcats);

    print scalar localtime, " writing files";
    for my $x ((map {{ -cat => $_, -file => $_, -list => $shelfcats->{$_},
			 -name => "$name $_", -duplex => 1,
			   -chunks => $opt{-chunks} }}
		keys %$shelfcats),
	       (map {{ -cat => $_, -file => "$_-box", -list => $boxcats->{$_},
			 -name => "$name $_ (boxed)", -duplex => 0,
			   -chunks => 0 }}
		keys %$boxcats))
      {
	$$x{-file} =~ s(/)(_)g;
	my $file = "$dir/$$x{-file}.tex";
	my $wr = new IO::File $file, "w" or die $file;
	$wr->print($_)
	  for shelfdex_tex_start(-name => $$x{-name}, -duplex => $$x{-duplex},
				 -shelf => $category{$$x{-cat}}{"doub"},
				 -chunks => $$x{-chunks});
	$wr->print($_) for @{ books_to_shelfdex_tex
				(-books => $$x{-list},
				 -chunk => 1, -prebreak => 1 ) };
	$wr->print($_) for shelfdex_tex_finish();
      }
    print scalar localtime, " done, shelfdex in $dir";
  }

sub multi_shelfdex
  {
    my %opt = @_;
    {
      my %unknown = %opt;
      delete @unknown{ qw( -dir -lists ) };
      die join " ", keys %unknown if %unknown;
    }
    my $dir = $opt{-dir} or die;
    -d $dir or mkdir $dir or do { warn "unable to make $dir"; return };
    { new IO::File "$dir/test", "w" or do{ warn "can't write in $dir"; return}}
    unlink "$dir/test";

    my $lists = $opt{-lists} or die;
    for my $type (sort keys %$lists)
      {
	(my $typedir = $type) =~ s(/)(_)g;
	$typedir = "$dir/$typedir";
	shelfdex(-books => $$lists{$type},
		 -boxing => 0, -chunks => undef,
		 -dir => $typedir, -name => "($type)");
      }
    return 1;
  }

sub inven_stuff_to_metahash
  {
    my $stuff = shift or die;
    my %meta;
    $meta{$1} = { codetohash($2) } while $stuff =~ s/\A([^{}]+)\{([^{}]+)\}//;
    die $stuff if $stuff;
    return \%meta;
  }

sub inven_metahash_to_stuff
  {
    my $meta = shift or die;
    return join "", map { $_ . "{" . hashtocode_nocheck($$meta{$_}) . "}" }
      sort keys %$meta;
  }

sub inven_splitdex
  {
    my $bklist = shift or die;
    my %split;
    for my $bk (@$bklist)
      {
	while (my ($type, $x) = each %{$$bk{"stuff"}})
	  { push @{$split{$type}}, { %$bk, "code" => hashtocode_nocheck($x) } }
      }
    return \%split;
  }

sub inven_load
  {
    my %opt = @_;
    my $which = $opt{-which} or die;
    my $file = $opt{-file} or die;
    local $parts{$which} = $parts{"inven"};
    $dex{$which} = datadex_order
      (loaddex ($file, $which) or return undef);
    for my $bk (@{$dex{$which}})
      {
	eval
	  {
	    my $stuff = $$bk{"stuff"};
	    $$bk{"stuff"} = inven_stuff_to_metahash ($stuff);

	    my @codes = sort map { keys %$_ } values %{$$bk{"stuff"}};
	    $_ = improper_shelfcode($_)
		|| (/@/ and "no \@s in inven item codes: '$_'")
		for @codes;
	    @codes = grep { $_ } @codes and die join "\n", @codes;

	    my $newstuff = inven_metahash_to_stuff($$bk{"stuff"});
	    $stuff eq $newstuff or die $stuff, "\n", $newstuff;
	  };
	die "invalid entry in $file:\n", panther($bk, $which), "\n", $@, "\n"
	  if $@;
	know ({"where" => $_ }, "where") for keys %{$$bk{"stuff"}};
      }
    return 1;
  }

sub inven_save
  {
    my %opt = @_;
    my $file = $opt{-file} or die;
    my $tmp = "$file.tmp";
    print "writing $tmp";
    my $out = new IO::File $tmp, "w"
      or return warn "failed opening $tmp for output";
    my @parts = @{ $opt{-parts} || $parts{"inven"} };
    my $stuff = grep { $_ eq "stuff" } @parts;
    for my $bk (@{$opt{-books}})
      {
	local $$bk{"stuff"} = inven_metahash_to_stuff($$bk{"stuff"}) if $stuff;
	$out->print (join '<', @$bk{@parts});
      }
    $out->close() or return warn "failed closing $tmp";
    print "moving $tmp to $file";
    rename $tmp, $file
      or return warn "failed renaming $tmp to $file";
    print "$file saved.";
    return 1;
  }

sub inventory
  {
    my $file = shift @ARGV or die "no invendexish file specified\n";
    lock_file($file) or exit 1;
    -e $file or do { (new IO::File $file, "w")->close() }
      or die "unable to create $file\n";

    {
      our %inven_types = map { $_ => [] } qw( CHECKOUT MOVE UNSHELVED FOUND );
      my $file = "$mitsfs/dexcode/inven-types";
      my $fh = new IO::File $file or die "no $file found\n";
      my @line = grep /\S/, $fh->getlines()
	or die "empty $file\n";
      chomp(@line);
      my (@bad, %know);
      for my $line (@line)
	{
	  my ($major) = $line =~ m{^(\w+): } or push @bad, $line and next;
	  exists $inven_types{$major} or push @bad, $line and next;
	  push @{$inven_types{$major}}, $line;
	  $line =~ s/\\.*//;
	  $line =~ s/\..*//;
	  undef $know{$line};
	}
      @bad and die join "\n", "bad lines in $file :", @bad, "";
      our $inven_majors_regexp = join '|', sort keys %inven_types;
      our $inven_types_regexp = join '|', map { "($_)" }
	map { @{$inven_types{$_}} } sort keys %inven_types;
      $known{"where"} = [ sort keys %know ];
    }
    if (my $flag = shift @ARGV)
      {
	$flag eq "-checkouts" or die "unknown flag $flag";
	my $memfile = "$mitsfs/dexcode/inven-members";
	my $fh = new IO::File $memfile or die "cannot read $memfile";
	know ({ "where" => $_ }, "where")
	  for grep { chomp; /\S/ } $fh->getlines();
      }

    print "loading inven file $file";
    inven_load(-file => $file, -which => "inven") or die "cannot load $file\n";
    print "loading datadex";
    loaddex("datadex", "main") or die "cannot load datadex\n";

    $needsave = 0;
    menuloop([
	      ["E", "Enter Inventory item", \&inven_enter_item],
	      ["G", "Grep datadex for pattern", sub { searchfor($POSTMATCH) }],
	      ["S", "Save $file", sub {
		inven_save (-file => $file, -books => $dex{"inven"})
		    and $needsave = 0;
	      }],
	      ((grep /\A\Q$ENV{USER}\E\Z/,
		`/usr/athena/bin/blanche -n -r dexmistress`)
	       ? ["O", "Other", sub { inventory_submenu($file) }]
	       : ()),
	      ["Q", "Quit", \&tryquit],
	     ]);
    die "got past menu loop somehow";
  }

# this is crap, it can't even be synchronized with locking correctly
sub inven_askuser_output
  {
    my $prompt = shift;
    die if @_;
    while (my $to = rdlnget($prompt, -noedit => 1))
      { return $to unless -e $to and not yesno("Overwrite existing $to? ") }
    return undef;
  }
sub inven_askuser_input
  {
    my $prompt = shift;
    die if @_;
    while (my $from = rdlnget($prompt, -noedit => 1))
      {
	return $from if -e $from;
	print "no such file $from";
      }
    return undef;
  }

sub inventory_submenu
  {
    my $file = shift or die;
    -e inv_access_file
      or print "Need to lock dexmaster usage with\n\t", inv_access_file
	and return;
    my $inv_access_reminder = join ("\n", "",
				    "Leaving " . inv_access_file . " alone;",
				    "\t" . "remember to rm it eventually...");
    my $primary = "$mitsfs/dexcode/primary-inventory";
    lock_file($primary) or return;
    menuloop([
	      ["M", "Merge in other inven file", sub { inven_merge($file) }],
	      ["S", "Shelfdexes for $file", sub {
		 $needsave and print "Need to save first." and return;
		 my $dir = rdlnget("Directory: ", -noedit => 1) or return;
		 my $lists = inven_splitdex($dex{"inven"});
		 /^CHECKOUT:/ and delete $$lists{$_} for keys %$lists;
		 multi_shelfdex(-lists => $lists, -dir => $dir);
	       }],
	      ["I", "Insert box presumptions", sub {
		inven_presume_boxing_usual (-books => $dex{"inven"});
		print "presumptions inserted";
	      }],
	      ["D", "Debox", sub {
		inven_debox ($dex{"inven"})
		    ? ($needsave = print "deboxed.") : print "naught to debox";
	      }],
	      ["1", "Tier 1 (nonempty delta overall)", sub {
		$needsave and print "There may be unsaved changes, BTW.";
		my $to = inven_askuser_output("Write to: ") or return;
		lock_file($to) or return;
		my $bks = $dex{"inven"};
		inven_presume_boxing_usual (-books => $bks);
		inven_sums(-books => $bks, -sumto => "del", -regexp => qr".");
		inven_save(-file => $to,
			   -books => [ grep { keys %{$$_{"del"}} } @$bks ]);
		unlock_file($to);
	      }],
	      ["2", "Tier 2 (similar books)", sub {
		my $from = inven_askuser_input("From file: ") or return;
		my $to = inven_askuser_output("To file: ") or return;
		print "reading $from";
		lock_file($from) or return;
		my $tier1 = loaddex ($from, "temp") # order irrelevant
		  or return warn "can't load $from";
		unlock_file($from);
		my $like_tier1 = inven_like ($tier1);
		my $like_datadex = inven_like ($dex{"main"});
		my %like = map { %{ $$like_datadex{$_} } } keys %$like_tier1;
		print "writing $to";
		lock_file($to) or return;
		my $wr = new IO::File $to, "w"
		  or return warn "failed opening $to for output";
		for my $like (sort { $a <=> $b } keys %like)
		  {
		    my $bk = $dex{"main"}[$like];
		    $wr->print (join "<", @$bk{@{$parts{"main"}}});
		  }
		$wr->close() or return warn "failed closing $to";
		unlock_file($to);
		print "saved $to";
	      }],
	      ["3", "Tier 3 (nearby books)", sub {
		my $from = inven_askuser_input("From file: ") or return;
		my $to = inven_askuser_output("To file: ") or return;
		lock_file($from) or return;
		my $tier2 = datadex_order
		  (loaddex ($from, "temp") or return warn "can't load $from");
		unlock_file ($from);
		my ($start, %n) = undef;
		for my $bk (reverse @$tier2)
		  {
		    my $main;
		    ($main, $start) = findbook (-find => $bk, -which => "main",
						-start => $start);
		    $main or warn panther($bk), "\n not known\n" and next;
		    undef $n{$_} for ( ($start-1)..($start+1) );
		  }
		$_ < 0 || $_ > $#{$dex{"main"}} and delete $n{$_} for keys %n;
		print "writing $to";
		lock_file($to) or return;
		my $wr = new IO::File $to, "w"
		    or return warn "failed opening $to for output";
		$wr->print(join "<", @$_{@{$parts{"main"}}})
		    for @{$dex{"main"}}[ sort { $a <=> $b } keys %n ];
		$wr->close() or return warn "failed closing $to";
		unlock_file($to);
		print "saved $to";
	      }],
	      ["V", "Visible Shelfdex slice (double-checking)", sub {
		$needsave and print "There may be unsaved changes, BTW.";
		my $from = inven_askuser_input("From file: ") or return;
		my $to = rdlnget("To directory: ", -noedit => 1) or return;
		lock_file($from) or return;
		my $tier3 = datadex_order
		  (loaddex ($from, "temp") or return warn "can't load $from");
		unlock_file($from);
		my $bks = inven_slice (-books => $tier3,
				       -main => $dex{"main"},
				       -inven => $dex{"inven"});
		inven_visible (-books => $bks, -zeros => 1);
		shelfdex(-dir => $to, -chunks => undef, -boxing => 0,
			 -name => "DOUBLE-CHECKING", -books => $bks);
		inven_save (-books => $bks, -file => "$to/visibledex",
			    -parts => $parts{"main"});
	      }],
	      ["F", "Filter", sub {
		 $needsave and print "There may be unsaved changes, BTW.";
		 my $from = inven_askuser_input("With file: ") or return;
		 my $to = inven_askuser_output("To file: ") or return;
		 print "reading $from";
		 lock_file ($from) or return;
		 my $pick = datadex_order
		   (loaddex ($from, "temp") or return warn "can't load $from");
		 unlock_file ($from);
		 my $start = undef;
		 ($_, $start) = findbook (-find => $_, -start => $start,
					  -books => $dex{"inven"})
		   for reverse @$pick;
		 print "writing $to";
		 lock_file ($to) or return;
		 inven_save (-file => $to, -books => [ grep { $_ } @$pick ]);
		 unlock_file ($to);
		 print "saved $to";
	       }],
	      ["C", "Checkouts prettydex", sub {
		 $needsave and print "There may be unsaved changes, BTW.";
		 my $from = inven_askuser_input("Members from: ") or return;
		 my $to = inven_askuser_output("To file: ") or return;
		 inven_load (-file => $from, -which => "temp")
		   or return warn "cannot load $from";
		 my %member = map { $_ => [] } grep { /^CHECKOUT:/ }
		   map { keys %{$$_{"stuff"}} } @{$dex{"temp"}};
		 for my $bk (@{$dex{"inven"}})
		   {
		     for my $ch (grep /^CHECKOUT:/, keys %{$$bk{"stuff"}})
		       {
			 my $mem = $member{$ch} or next;
			 my %foo = %$bk;
			 $foo{"code"} = hashtocode_nocheck($$bk{"stuff"}{$ch});
			 push @$mem, \%foo;
		       }
		   }
		 print "writing $to";
		 my $out = new IO::File $to, "w" or die;
		 multilist_prettydex( -dexname => "checkouts",
				      -filehandle => $out,
				      -by => "author",
				      -lists => \%member );
		 print "wrote $to";
	       }],
	      ["R", "Reserve under/overflows", sub {
		$needsave and print "There may be unsaved changes, BTW.";
		print "figuring out what's there";
		my $bks = inven_slice (-books => $dex{"inven"},
				       -main => $dex{"main"},
				       -inven => $dex{"inven"});
		$$_{"code"} =~ s/@//g for @$bks;
		$$_{"stash hash"} = { codetohash ($$_{"code"}) } for @$bks;
		inven_visible (-books => $bks, -zeros => 0);
		$$_{"stuff"}{"TEMP:"} = { codetohash ($$_{"code"}) } for @$bks;
		inven_sums (-books => $bks, -sumto => "pushable",
			    -regexp => qr"^(TEMP|UNSHELVED)");
		inven_sums (-books => $bks, -sumto => "pullable",
			    -regexp => qr"^(TEMP|UNSHELVED|CHECKOUT)");
		delete $$_{"stuff"}{"TEMP:"} for @$bks;
		my @reserve = qw( CH CP CX SCX P PA LP LPA VLP VLPA
				  SR-H SR-HA SR-L SR-LP SR-LPA SR-P SR-PA
                                  SR-VLH SR-VLHA SR-VLP SR-VLPA );
		my (@simple_over, @complex_over);
		my (@simple_under, @complex_under);
		for my $bk (@$bks)
		  {
		    my @inres = grep { exists $$bk{"pushable"}{$_} } @reserve;
		    my $nres = 0;
		    $nres += $$bk{"pushable"}{$_} for @inres;
		    if ($nres > 1)
		      {  # Reserve overflow
			my $complex = 0;
			for my $hash (map { $$bk{"stuff"}{$_} }
				      grep /^UNSHELVED:/,
				      keys %{$$bk{"stuff"}})
			  { $complex ||= grep { exists $$hash{$_} } @inres }
			if ($complex)
			  { push @complex_over, $bk }
			else
			  { push @simple_over, $bk }
		      }
		    elsif ($nres <= 0)
		      { # possible Reserve underflow
			my $pullable = $$bk{"pullable"};
			if (grep { exists $$pullable{$_} } qw( C/P C/PA )
			    or
			    grep { exists $$bk{"stash hash"}{$_} } @reserve
			    and
			    grep { exists $$pullable{$_} } qw( H HA RH RP ))
			  { # actual Reserve underflow
			    my $complex = 0;
			    for my $hash (map { $$bk{"stuff"}{$_} }
					  grep /^(UNSHELVED|CHECKOUT):/,
					  keys %{$$bk{"stuff"}})
			      { $complex ||= grep { exists $$hash{$_} }
				             qw( C/P C/PA H HA RH RP ) }
			    if ($complex)
			      { push @complex_under, $bk }
			    else
			      { push @simple_under, $bk }
			  }
		      }
		  }
		# currently 'code' is what inven_visible shows;
		# prettydex the simple ones with that
		prettydex (-books => \@simple_over,
			   -by => "author", -nomulti => 1,
			   -tex => "easy_overflows",
			   -supple => "Reserve Overflows");
		prettydex (-books => \@simple_under,
			   -by => "author", -nomulti => 1,
			   -tex => "easy_underflows",
			   -supple => "Reserve Underflows");
		# it might be nice to drop from 'stuff' things that don't
		# participate in these problems, i.e. anything but UNSHELVED
 		# and CHECKOUT, but that would affect the *real* invendex
		# and be Very Very Bad if we then saved the file, so don't.
		inven_save (-books => \@complex_over,
			    -file => "/tmp/complex_reserve_overflows",
			    -parts => [ qw( author title series code stuff )]);

		inven_save (-books => \@complex_under,
			    -file => "/tmp/complex_reserve_underflows",
			    -parts => [ qw( author title series code stuff )]);

		inven_save (-books => \@simple_over,
			    -file => "/tmp/simple_reserve_overflows",
			    -parts => [ qw( author title series code ) ]);

		inven_save (-books => \@simple_under,
			    -file => "/tmp/simple_reserve_underflows",
			    -parts => [ qw( author title series code ) ]);
	      }],
	      ["P", "Pull to boxes/hasslecomm", sub {
		$needsave and print "need to save first" and return;
		print "figuring out what's there";
		my $bks = inven_slice (-books => $dex{"inven"},
				       -main => $dex{"main"},
				       -inven => $dex{"inven"});
		($$_{"stash code"} = $$_{"code"}) =~ s/@//g for @$bks;
		inven_visible (-books => $bks, -zeros => 0);
		my ($shelfbks, $boxbks) = shelfdex_boxing ($bks);
		if (@$boxbks)
		  {
		    print "pulling into boxes";
		    for my $bk (@$boxbks)
		      { # augment, not replace, existing MOVEs
			my %x = codetohash ($$bk{"code"});
			$$bk{"stuff"}{"MOVE: BOX"}{$_} -= $x{$_} for keys %x;
		      }
		    $needsave = 1;
		  }
		else
		  { print "(nothing else to pull into boxes)" }
		my $toss = 0;
		for my $bk (@$shelfbks)
		  {
		    my %x = codetohash ($$bk{"code"});
		    $x{$_} -= $category{basecode($_)}{"keep"} for keys %x;
		    $x{$_} <= 0 and delete $x{$_} for keys %x;
		    $$bk{"stuff"}{"MOVE: WITHDRAW"}{$_} -= $x{$_} for keys %x;
		    $toss ||= scalar keys %x;
		  }
		print $toss ? "withdrawing excess" : "(no excess to withdraw)";
		$needsave ||= $toss;
	      }],
	      ["A", "Apply", sub {
		 $needsave and print "Need to save first." and return;
		 if ($ENV{"PWD"} !~ m(/mitsfs/dex\Z))
		   {
		     print "You're in $ENV{PWD},\nnot $mitsfs/dex.";
		     yesno ("Apply anyway? ") or return;
		   }
		 my $except = inven_askuser_input("Deferring: ") or return;
		 my $dir = rdlnget("Intentions dir: ", -noedit => 1) or return;
		 rmdir $dir;  # succeeds iff dir exists but is empty
		 mkdir $dir or print "can't mkdir $dir" and return;
		 lock_file("dexmaster") or return;
		 loaddex("lostdex", "lost");
		 print scalar localtime, " loading $except";
		 inven_load(-file => $except, -which => "defer") or return;
		 print scalar localtime, " merging main & inven data";
		 my $start = undef;
		 for my $bk (reverse @{$dex{"inven"}})
		   {
		     my $match;
		     ($match, $start) = findbook (-find => $bk,
						  -books => $dex{"main"},
						  -start => $start);
		     $match or die panther ($bk);
		     $$match{"stuff"} = $$bk{"stuff"};
		     $bk = $match;
		   }
		 # now things done to books in $dex{inven} affect $dex{main}
		 print scalar localtime, " presuming boxing";
		 inven_presume_boxing_usual (-books => $dex{"inven"});
		 print scalar localtime, " deferring";
		 # remove books from $dex{"inven"}, put them into $dex{"defer"}
		 $start = undef;
		 for my $defer (reverse @{$dex{"defer"}})
		   {
		     my $found;
		     ($found, $start) = findbook (-find => $defer,
						  -which => "inven",
						  -start => $start);
		     $found or die panther($defer);
		     keys %{$$found{"stuff"}} or die panther($found);
		     $defer = splice @{$dex{"inven"}}, $start, 1;
		   }
		 print scalar localtime, " saving $dir/defer";
		 inven_save (-file => "$dir/defer", -books => $dex{"defer"},
			     -parts => [ @{$parts{"inven"}}, "code" ])
		   or die;
		 print scalar localtime, " making todo sums";
		 inven_sums (-books => $dex{"inven"},
			     -sumto => "todo", -regexp => qr".");
		 print scalar localtime, " converting to todo codes";
		 my @change = grep  # only those with a net change
		   { $$_{"todo"} = hashtocode_nocheck ($$_{"todo"}) }
		     @{$dex{"inven"}};
		 print scalar localtime, " saving $dir/apply";
		 inven_save (-file => "$dir/apply", -books => \@change,
			     -parts => [ @{$parts{"inven"}}, "todo" ])
		   or die;
		 print scalar localtime, " adding";
		 $$_{"was"} = $$_{"code"} for @change;
		 # invoke *panthercomm* add() at this point!
		 {
		   local $inven = 1;
		   local $restoring = 1;
		   #print join "<", @$_{qw( author title series code todo )}and
		   add ($_, $$_{"todo"}, "main", 0) # affects actual books!
		     for @change;
		 }
		 print scalar localtime, " saving $dir/change";
		 inven_save (-file => "$dir/change", -books => \@change,
			  -parts => [qw( author title series was todo code )]);
		 print scalar localtime, " applied!";
		 yesno("Abort? ") and exit 1;
		 {
		   local $newbooksfile = "/dev/null";
		   local $reviewbooksfile = "/dev/null";
		   local $tempfile = "/dev/null";
		   savedex("main");
		 }
		 print $inv_access_reminder;
		 unlock_all();
		 exit 0;
	       }],
	      ["B", "Back to main menu", sub { return "quit menu"; }],
	      # don't offer "quit"; want to go back to main menu for reminder
	     ]);
    unlock_file($primary);
    print $inv_access_reminder;
  }

sub inven_like
  {
    my $books = shift or die;
    my %like;
    for my $index (0..$#$books)
      {
	my $bk = $$books[$index];
	my @a = split /[|]/, $$bk{"author"};
	my @t = split /[|=]/, $$bk{"title"};
	s/\s*\(.*?\)// for @a, @t;
	&editplacefield for @a, @t;
	for my $a (@a) { for my $t (@t) { undef $like{"$a<$t"}{$index} } }
      }
    return \%like;
  }

# takes a list of books that already have both "code" and "stuff"
# set appropriately; resets "code" in place, leaving "stuff" alone
sub inven_visible
  {
    my %opt = @_;

    # 'stuff' carries through shallow copying
    delete $$_{"stuff"}{"TEMP:"} for @{$opt{-books}};
    my ($shelfbks, undef) = shelfdex_boxing ($opt{-books});
    $$_{"stuff"}{"TEMP:"} = { codetohash ($$_{"code"}) } for @$shelfbks;
    inven_sums( -books => $opt{-books},
		-sumto => "visdelta",
	        -regexp => qr"^(TEMP|FOUND|MOVE):" );
    delete $$_{"stuff"}{"TEMP:"} for @$shelfbks;

    my ($mayshelve, $maybox) = shelfdex_boxing_desc();
    for my $bk (@{$opt{-books}})
      {
	my $tot = $$bk{"visdelta"};
	if (my $atsigns = $$bk{"code"} =~ /@/
	    or $opt{-zeros})
	  {
	    my %orig = codetohash ($$bk{"code"});
	    if ($atsigns)
	      {
		for my $at (grep { exists $orig{'@'.$_} } keys %$tot)
		  { $$tot{'@'.$at} += delete $$tot{$at} }
	      }
	    if ($opt{-zeros})
	      {
		for my $z (grep { not exists $$tot{$_} } keys %orig)
		  { $$tot{$z} = 0 if exists $$mayshelve{basecode($z)} }
	      }
	  }
	$$bk{"code"} = hashtocode_nocheck( delete $$bk{"visdelta"} );
      }
    return undef;
  }

sub inven_slice  # all three lists must be in datadex order already
  {
    my %opt = @_;
    die if grep { not exists $opt{$_} } qw( -books -main -inven );
    my @out;
    my $n = undef;
    for my $bk (reverse @{$opt{-books}})
      {
	my $main;
	($main, $n) = findbook (-find => $bk, -books => $opt{-main},
				-start => $n);
	warn "can't find ", panther($bk) unless $main;
	my ($invbk) = findbook (-find => $bk, -books => $opt{-inven});
	$invbk ||= { "stuff" => {} };
	unshift @out, { %$main, "stuff" => $$invbk{"stuff"} };
      }
    return \@out;
  }

sub inven_debox
  { return grep { defined } map { delete $$_{"stuff"}{"BOXED"} } @{$_[0]} }

sub inven_merge
  {
    my $mainfile = shift or die;
    $needsave and print "Need to save first." and return;
    my $take = rdlnget("file: ", -noedit => 1) or return;
    -e $take or print "$take not found" and return;
    lock_file($take) or return;

    inven_load(-file => $take, -which => "temp") or die "failed loading $take";
    inven_merge_dex (-from => "temp", -into => "inven");
    my %where;
    for my $bk (@{$dex{"temp"}})
      { ++$where{$_} for keys %{$$bk{"stuff"}} }
    delete $dex{"temp"};

    $where{"CHECKOUT"} = 0;
    $where{"CHECKOUT"} += $where{$_} and delete $where{$_}
      for grep /^CHECKOUT:/, keys %where;
    printf "% 5d $_\n", $where{$_} for sort keys %where;

    unless (yesno("Keep these? "))
      {
	# we've already munged the contents of @{$dex{inven}}
	# and we don't have a way to undo that, so just abort
	# (we insisted !$needsave earlier so that's ok)
	unlock_all();
	print "Aborting and exiting.";
	exit 0;
      }
    my $mvto = rdlnget("Move $take to: ", -cont => 1, -noedit => 1);
    -d $mvto and $mvto = "$mvto/$take";
    rename $take, $mvto or die "failed renaming";
    print "renamed $take to $mvto";
    inven_save (-file => $mainfile, -books => $dex{"inven"})
	? $needsave = 0 : die "failed saving $mainfile";
    unlock_file($take);
    print "Merger of $take (now $mvto) into $mainfile complete.";
  }

# assumes both are in datadex order already
sub inven_merge_dex
  {
    my %opt = @_;
    my $into = $dex{$opt{-into}};
    my $n = undef;
    for my $bk (reverse @{$dex{$opt{-from}}})
      {
	my $cur;
	($cur, $n) = findbook (-find => $bk, -books => $into, -start => $n);
	if ($cur)
	  {
	    $$cur{"stuff"} = sum_metahashes ($$cur{"stuff"}, $$bk{"stuff"});
	    keys %{$$cur{"stuff"}} or splice @$into, $n, 1 and --$n;
	  }
	else { splice @$into, $n, 0, $bk }
      }
  }


sub inven_display_metahash
  {
    my $meta = shift or die;
    my $flag = shift || "";
    print "\t" . ($_ eq $flag ? "*" : " ") . $_
	. "\t" . hashtocode_nocheck($$meta{$_})
	for sort keys %$meta;
  }

sub inven_enter_item
  {
    our $where_default;
    {
      print "";

      my $mainbook = specify();
      defined $mainbook or return;
      $mainbook or redo;
      my ($invbook, $n) = findbook (-find => $mainbook, -which => "inven");
      my $isnew = not $invbook
	  and print "currently no inven entries"
	  and $invbook = { %$mainbook, "stuff" => {} };
      inven_display_metahash ($$invbook{"stuff"});

      our (%inven_types, $inven_majors_regexp, $inven_types_regexp);
      my $where = inputval("where", { "where" => $where_default }) or redo;
      my ($maj) = $where =~ /^($inven_majors_regexp)/
	  or print "must start ", map { "$_: " } sort keys %inven_types
	  and redo;
      $where =~ /\A($inven_types_regexp)\Z/
	  or print join ("\n", "legal $maj looks like", @{$inven_types{$maj}})
	  and redo;
      know({"where" => $where}, "where");
      $where_default = ($maj eq "CHECKOUT" ? "$maj: " : $where);

      my $what = inputval("code") or redo;
      $what =~ /@/ and print "no \@s in inven item codes" and redo;
      my $hash = { codetohash($what) };
      my @bad = map { improper_shelfcode($_) } sort keys %$hash;
      @bad and print join "\n", @bad and redo;

      $hash = sum_hashes ($hash, $$invbook{"stuff"}{$where})
	  if exists $$invbook{"stuff"}{$where};

      if ($where =~ /^FOUND: MISSING/)
	{
	  grep { $$hash{$_} > 0 } keys %$hash
	      and print "cannot bring MISSING counts above zero"
	      and redo;
	}
      elsif ($where !~ /^MOVE:/)
	{
	  grep { $$hash{$_} < 0 } keys %$hash
	      and print "cannot bring non-MISSING counts below zero"
	      and redo;
	}
      $$invbook{"stuff"}{$where} = $hash;

      keys %{$$invbook{"stuff"}{$where}} > 0
	  or print "deleting book's $where entry"
	  and delete $$invbook{"stuff"}{$where};

      $isnew and splice @{$dex{"inven"}}, $n, 0, $invbook;

      if (keys %{$$invbook{"stuff"}})
	{
	  print panther($mainbook);
	  inven_display_metahash($$invbook{"stuff"}, $where);
	}
      else
	{
	  splice @{$dex{"inven"}}, $n, 1;
	  print "deleted book's inven entries entirely";
	}
      $needsave = 1;
    }
  }

sub inven_sums  # frob list in place
  {
    my %opt = @_;
    $opt{-sumto} and $opt{-regexp} and $opt{-books} or die;
    for my $bk (@{$opt{-books}})
      {
	my @use = grep /$opt{-regexp}/, keys %{$$bk{"stuff"}};
	$$bk{$opt{-sumto}} = sum_hashes( @{$$bk{"stuff"}}{ @use } );
      }
    return undef;
  }

sub inven_presume_boxing_usual  # -books list must be in datadex order already
  {
    my %opt = @_;
    my $bks = inven_slice (-books => $opt{-books},
			   -main => $dex{"main"}, -inven => $dex{"inven"});
    inven_debox ($bks);
    inven_sums (-books => $bks, -sumto => "delta", -regexp => qr".");
    inven_presume_boxing (-books => $bks, -delta => "delta");
  }

sub inven_presume_boxing # frob list in place; its books must have "code" set!
  {
    my %opt = @_;
    my $bklist = $opt{-books} or die; # must be datadex-ordered
    my $dfield = $opt{-delta} or die; # and have this field set to sum hash
    # up to caller to have deboxed() if desired
    my (undef, $maybox) = shelfdex_boxing_desc();

    my $anywhere_cats = shelfdex_split_cats ($bklist);
    for my $cat (grep { exists $$maybox{$_} } keys %$anywhere_cats)
      {
	# any net missing (i.e. on shelves) in boxable category
	# is presumed to be reflected by "excess" in the boxes
	for my $bk (@{$$anywhere_cats{$cat}})
	  {
	    (my $c = $$bk{"code"}) =~ s/@//;
	    next unless exists $$bk{$dfield}{$c};
	    my $d = $$bk{$dfield}{$c};
	    $$bk{"stuff"}{"BOXED"}{$c} = -$d if $d < 0;
	  }
      }

    my (undef, $boxbks) = shelfdex_boxing ($bklist);
    my $boxcats = shelfdex_split_cats ($boxbks);
    for my $cat (keys %$boxcats)
      {
	# any excess (physical or theoretical)
	# is presumed to be reflected by "missings" in the boxes
	# _up to the quantity previously thought boxed_
	# (if we think we only have N in boxes, can miss at most N of them...)
	for my $bk (@{$$boxcats{$cat}})
	  {
	    (my $c = $$bk{"code"}) =~ s/@//;
	    next unless exists $$bk{$dfield}{$c};
	    my $d = $$bk{$dfield}{$c};
	    $$bk{"stuff"}{"BOXED"}{$c} = -($$bk{"n"} < $d ? $$bk{"n"} : $d)
		if $d > 0;
	  }
      }

    # leave $$bk{$dfield} alone; the caller can run the list
    # through inven_deltas() again if they want to account for
    # these BOXED presumptions there, or to another dfield
    return undef;
  }

sub yeardex {
  $dex{year} = [];
  for my $month (@month) {
    local $OUTPUT_AUTOFLUSH = 1;
    local $OUTPUT_RECORD_SEPARATOR = "";
    print scalar localtime;
    print " mitsfs/dex/newdex-$month... ";
    if (loaddex("$mitsfs/dex/newdex-$month", "temp")) {
      print "reading... ";
      for my $bk (@{$dex{"temp"}}) {
	add($bk, undef, "year") if $$bk{'code'};
      }
      print "done";
    }
    else {
      print "not found; continuing";
    }
    print "\n";
  }
  my @now = localtime();
  my $from = ucfirst join " ", $month[($now[4]+1)%12], $now[5]+1899;
  my $to = ucfirst join " ", $month[$now[4]], $now[5]+1900;
  prettydex(-which => "year", -supple => "Yeardex: $from to $to",
	    -by => $_, -tex => "yeardex-$_")
    for qw( author title );
}


sub patchdex {
  local $| = 1;
  local $limit{"max"} = 0;
  local $limit{"min"} = 0;
  my @parts = @{$parts{"patch"}};
  my $spec = rdlnget("Patches after year/month/day: ") or return;
  my @now = (localtime)[5, 4, 3];
  my $bound = sprintf "%04d-%02d-%02d", ($spec =~ m<^(\d+)/(\d+)/(\d+)$>);
  my $now =   sprintf "%04d-%02d-%02d", $now[0]+1900, $now[1]+1, $now[2];
  my ($yr, $mon, $day) = split /-/, $bound;

  print "Will use changes after $bound, through $now";
  my %month;
  @month{@month} = (1..12);
  $dex{"patch"} = [];
  `attach -q sipb`; # for zmore

  print "Looking for datadex diffs";
  chdir $mitsfs;
  my %dir;
  for (`find dex/diffs -type d -name "diffs????-??"`) {
    chomp;
    my $dir = $_;
    s/.*diffs//;
    $_ ge "$yr-$mon" and $dir{$_} = $dir;
  }
  my @dir = map { $dir{$_} } sort keys %dir;
  for my $dir (@dir, "dex") {
    print "Looking in $dir";
    chdir "$mitsfs/$dir";
    for my $file (<forw.*>) {
      $_ = lc $file;
      s<^.{9}(.{20})(\.gz)?\Z><$1> or next;
      s/(...)/$month{$1}/e;
      my $from = sprintf "%04d-%02d-%02d", (split /_+/)[3, 0, 1];
      next unless $from gt $bound;
      print $file;
      for (`zmore $file`) {
	if (s/^([<>]) //) {
	  my $dir = $1;
	  my %bk;
	  chomp;
	  @bk{ @parts } = split /</, $_, -1;
	  $bk{"code"} or next;
	  if ($dir eq "<") {
	    $bk{"code"} =~ s/(,|\Z)/:1$1/g;
	    $bk{"code"} =~ s/(:\d+):1/$1/g;
	    $bk{"code"} =~ s/:/:-/g;
	  }
	  add(\%bk, undef, "patch");
	}
      }
    }
  }
  chdir $ENV{PWD};  # whence we started
  print "Diffs read; writing patchdex out";
  prettydex(-which => "patch", -by => "author", -tex => "patchdex-$bound",
	    -supple => "Patch from $bound to $now");
  print "Generating touchdex...";
  $dex{"touch"} = [];
  for my $bk (@{$dex{"patch"}})
    {
      my ($cur) = findbook (-find => $bk, -which => "main");
      add($cur, undef, "touch") if $cur;
    }
  prettydex(-which => "touch", -by => "author", -tex => "touchdex-$bound",
	    -supple => "Touched from $bound to $now");
}


sub basecode {
  my $code = shift;
  local $_ = $code;

  tr/@//d;
  # some doubles have "fooDx\d\d\d" with "fooD" as base, x as letter
  # also, GNs are just funky (and annoying)
  tr/0-9//d and s/D.$/D/ || s/GN\./GN/;
  return $_ if exists $category{$_};
  return $code;
}


sub panther {
  my $bk = shift;
  my $which = shift || 'main';

  return join '<', @$bk{@{$parts{$which}}};
}


sub nicetitle {
  my ($bk, $title, $series);
  if (@_ < 2)
    {
      $bk = shift;
      $title = $$bk{"title"};
      $series = $$bk{"series"};
    }
  else
    {
      ($title, $series) = @_;
    }

  my @t = split /\|/, $title;
  my @s = split /\|/, $series;

  foreach (@t) {
    s/=.*$//;
  }

  if (@s > 0) {
    if (@s == @t) {
      for (0..$#t) {
	$t[$_] = "$t[$_] [$s[$_]]";
      }
    }
    elsif (@t == 1) {
      $t[0] = "$t[0] [" . (join '|', @s) . "]";
    }
    elsif (@s == 1) {
      foreach (@t) {
	$_ = "$_ [$s[0]]";
      }
    }
    else {  # hopefully this case never happens
      print "Wacky title/series match: "
	. ($bk ? panther($bk) : "$title<$series");
      for (@t) {  # if #series > #titles, we just lose the extras...
	$_ .= " [" . (shift @s) . "]" if @s;
      }
    }
  }

  return join '|', @t;
}


sub tempsave {
  return if $restoring;
  my $bk = {%{shift @_}};
  my %old = codetohash (shift);
  my %new = codetohash (shift);
  local *FH;

  foreach (keys %old) {
    ($new{$_} ||= 0) -= $old{$_};
    delete $new{$_} unless $new{$_};
  }
  $$bk{'code'} = join ',', map { "$_:$new{$_}" } keys %new;

  open FH, ">>$tempfile" or return warn "Failed saving change in temp file!\n";
  print FH panther ($bk);
  close FH;
}


sub restore {
  local *FH;
  my @parts = @{$parts{'main'}};

  return print "No file of temporary changes to restore" unless -e $tempfile;

  open FH, $tempfile or return print "Ack! Can find but not open $tempfile!";
  $restoring = 1;
  while (<FH>) {
    my %bk;
    next unless /\S/;
    chomp;
    @bk{ @parts } = split /</, $_, -1;
    placefields (\%bk);
    add (\%bk);
    know (\%bk);
  }
  $restoring = 0;
  close FH;
  savedex ('main');
}


sub review {
  my $bk = shift;
  rmbook ($bk, "review", "failsafe");
  add ({%$bk}, undef, "review") if $$bk{'code'};
}


sub tryquit {
  return unless !$needsave or
      yesno ("There may be unsaved changes. Exit anyway? ");
  return unless yesno ("Really? ");
  unlink $tempfile if $tempfile;
  unlock_all();
  exit 0;
}


sub init {
  my @basicparts = qw ( author title series code );

  %parts = ('main' => \@basicparts,       # datadex
	    'lost' => \@basicparts,       # lostdex
	    'new' => \@basicparts,        # newdex-currentmonth, save
	    'supple' => \@basicparts,     # newdex-pastmonth, order & print
	    'sale' => \@basicparts,       # saledex
	    'temp' => \@basicparts,       # temporary whatever
	    'year' => \@basicparts,       # yeardex (all newdex-mon's)
	    'patch' => \@basicparts,      # patchdex (diffs)
	    'review' => \@basicparts,     # review-currentmonth
	    'inven' => [ qw( author title series stuff ) ],
	   );

  %limit = ('max' => 1, 'min' => 1);  # for shelfcode hash limits

  $articles = qr"(?:A|AN|THE)";
}


sub searchfor {
  my @sec = qw(author title series);
  my (%pat, $bk, $pat);
  local $\ = "\n";
  local $SIG{'PIPE'} = "IGNORE";

  $_ = happyline($_[0]) || rdlnget ("Grep for:  ") || return;

  my $pager = pager() or die;
  my $oldfh = select $pager;

  if (/[<`]/) {
    @pat{ @sec } = map { happyline($_) } split / ?[<`] ?/;
    eval sprintf
	'for $bk (@{$dex{main}}) { print panther ($bk) if %s }',
	join (' and ', map { '$$bk{' . $_ . '} =~ /' . $pat{$_} . '/' }
	      grep { defined $pat{$_} and length $pat{$_} } @sec);
  }
  else {
    $pat = $_;
    eval sprintf
	'for $bk (@{$dex{main}}) { print panther ($bk) if %s }',
	join (' or ', map { '$$bk{' . $_ . '} =~ /' . $pat . '/' } @sec);
  }

  select $oldfh;
  $pager->close();
}


sub pager {
  use IO::Pipe;
  local %ENV = %ENV;
  defined $ENV{PAGER} or $ENV{PAGER} = "less", $ENV{LESS} ||= "-eM";
  my $pipe = new IO::Pipe;
  $pipe->writer ($ENV{PAGER});
  return $pipe;
}


sub sales {
  my @menu;
  local $limit{"max"} = 0;  # no max limit to number of copies in saledex

  print "Loading in datadex...";
  loaddex ("$mitsfs/dex/datadex", 'main') || die "Cannot open datadex";
  loaddex ('saledex', 'sale') || yesno ("Start new saledex? ") || exit;

  menuloop ([
	     ["C", "Continue editing saledex", sub { { # loop internally
	       my $bk = specify () or return;
	       my ($cur) = findbook (-find => $bk, -which => 'sale');

	       print "(currently ", ($cur
				     ? ("in saledex: ", panther($cur))
				     : "not in saledex)"),
				       "\n";

	       my $val = inputval ("code") or redo;

	       if ($cur) {
		 add ($cur, $val, 'sale');
	       }
	       else {
		 $cur = { %$bk };
		 $$cur{'code'} = $val;
		 add ($cur, undef, 'sale');
		 know ($cur);
	       }
	       print "\n", (length $$cur{'code'}
			    ? ("Selling ", panther($cur))
			    : "Book deleted from saledex."),
			      "\n";
	       $needsave = 1;
	       redo;
	     } }],
	     ["S", "Save saledex", sub { savedex ('sale') }],
	     ["Q", "Quit", \&tryquit ],
	    ]);
}


# 1 if we have a stop-seeking copy, -1 for keep-seeking copies, 0 for no copies
sub wehave {
  my $try = shift;
  my ($bk) = findbook (-find => $try, -which => "main");
  my %table;

  return 0 unless $bk and $$bk{'code'};

  %table = codetohash ($$bk{'code'});
  foreach (keys %table) {
    return 1 unless $category{ basecode ($_) }{'seek'};
  }
  return -1;
}



sub dexstats {
  print "loading datadex...";
  loaddex("datadex", "main") or die "Cannot open datadex";
  print "counting:";
  my %count = map { $_ => 0 } keys %category;
  my %doub;
  for my $bk (@{$dex{main}})
    {
      my %code = codetohash($$bk{code});
      for my $c (keys %code)
	{
	  my $bc = basecode($c);
	  exists $doub{$c} ? next : undef $doub{$c} if $category{$bc}{"doub"};
	  $count{$bc} += $code{$c};
	}
    }
  my $tot = 0;
  for my $c (sort keys %count)
    {
      print $c, "\t", $count{$c};
      $tot += $count{$c};
    }
  print "\n", "Total $tot";
  exit 0;
}


sub soften_dex
  { [ map { { %$_, "code" => soften_code ($$_{"code"}) } } @{$_[0]} ] }

sub soften_code
  {
    my %hash = codetohash ($_[0]);
    $hash{$_} > $category{basecode($_)}{"soft"}
      and $hash{$_} = $category{basecode($_)}{"soft"}
	for keys %hash;
    return hashtocode_nocheck (\%hash);
  }


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

### something to check a datadexlike file by happylining it
### (in order and modified as per rdlnget and so on)

# stats
# note boxing to panthercomm
# gapdex
# html of recent books
# modify series wholesale
# unlink tilde files?

# %{$dex{$name}}

# each dex is a plain array of books
# each book is an anon hash keyed by @{$parts{name of dex}},
# eg qw(author title series code) for 'main'

# books are brought into existence only by &specify, &loaddex, &restore;
# these _must_ &placefields
# &add must also do this for 'new' books