# purldoc.pl - Part of the kinder, gentler #Perl.

# Though he hates to admit it, this was written by the gent
# on EFNet #Perl known most often as Masque.  Comments to 
# masque@pound.perl.org.  This code is covered under the same
# license as the rest of infobot.

# Eternal thanks to oznoid for writing the other bits, and 
# for being a good friend to all Perldom.  We're fortunate
# to have him.

# Please note that in this version, purldoc only searches the
# question _titles_.  This is MUCH faster, and reduces the 
# amount of work that the host machine has to do.  This is
# the same way that perldoc -q does it, so don't complain
# _too_ loudly. 

# KNOWN BUGS: Still sucks in many ways.

sub purldoc {

  my @results;
  my $msg_params;
  my $msg_limit = 6;
  my $pd_return;
 
  if ($msgType eq 'public') {
    $pd_return = &purldoc_lookup($message, \@results);
    &say($pd_return) and return unless @results;
    for (0..($param{'purldoc_max_public'} - 1)) { &say($results[$_]) if $results[$_]; }

# This is one of those ideas that sounds great until you actually
# implement it.  I now think the following concept sucks.  Hard.
# On the off chance you disagree with me, leave it in.  :]
 
        if ($param{'purldoc'} eq 'verbose') {
            &msg($who, "There are " . (scalar @results - $param{'purldoc_max_public'}) . " more matches for your query.  /msg me with the query to see more.");
        }
    } else {
        ($message, $msg_params) = split /;/, $message, 2; 
        $pd_return = &purldoc_lookup($message, \@results);
        &msg($who, $pd_return) and return unless @results;

      # Complain if the user wants a specific number of all messages.

        if ($msg_params =~ /\d+/ && $msg_params =~ /all/i) {
          &msg($who, "Oh come now.  Don't give me a number AND 'all'."); 
          return;
        }

      # Many thanks to crimson for the following join incantation.
      # This is basically join() with a limit of $msg_limit items.  Neat.
      # I've uglified it by putting spaces in it and thus making it human
      # readable.  ;)  The solution used lower to truncate the array to 
      # the message limit is somewhat more elegant, but I'm leaving this
      # in comments because it's neat.

      # &msg($who, join("; ",(@results[0..(@results < $msg_limit ? @results - $msg_limit : $msg_limit - 1)]))) and return unless $msg_params;

        $msg_limit = $1 if $msg_params =~ /(\d+)/;

      # Okay, so it turns out that 'all' is a bit of a lie.  It's
      # more like 'all, unless X'.  30 will tie the bot up long enough, 
      # and people need to learn to limit their matches to some degree
      # anyway.  PATCHES ARE WELCOME.  Yes, I'm aware the clumping code
      # is total baby-talk.  See earlier 'patches' comment. 

      # clump limit is hardcoded.

      # Look what happens when you try to crossbreed style rules!  
      # ;]  Hey, for that matter, check out the low-quality "let's pass
      # the -w test" kludge!  Did I mention that this whole subroutine
      # was written over four days, spending no more than 10 minutes at
      # a time per sitting?  I'll rewrite this, but for now I just want
      # to get the output working.  Besides, I've got a couple of hours
      # before the next code release....

      # Come to think of it, we're not using -w at all.  I am 
      # DEFINITELY going to rewrite this, so please stop laughing
      # at this code now.  The other subroutine is reasonably well
      # written, go read that one instead.

        if (defined $msg_params && $msg_params =~ /all/i) { 
            unless (@results > 30) { $#results = $msg_limit - 1 }
            else                   { $#results = 29;            }
        } else {
          # Thanks, lucs!  $#results = $msg_limit -1 is neato.  :]
            $#results = $msg_limit - 1 if @results > $msg_limit;  
        }

        if (defined $msg_params && $msg_params =~ /clump/i) {
            my $clump;
            for (0..$#results) {
                $clump .= "$results[$_]; ";
                if ($_ == $#results) {
                    $clump =~ s/; $//;
                    &msg($who, $clump);
                    last;
                }
                unless (($_  + 1) % 4) {
                    $clump =~ s/; $/.../;
                    &msg($who, $clump);
                    $clump = ""; 
                    sleep 1;
                }
            }
        } else {  
            for (0..$#results) { 
                &msg($who, $results[$_]);
                sleep 1 unless ($_ + 1) % 3; 
            }
        }       
         
    }

} # End sub purldoc()

# I probably don't need to pass the array to the subroutine, but
# it looks more impressive when the subroutine is all pr0totyped,
# etc., and perhaps I can distract you, the noble reader, from
# noticing the other less impressive bits of this code by putting
# in overly complicated code.  We pass the array because we're only
# using return values if the sub blows up.  Lame?  Yes.  Stupid?
# Perhaps.  Intentional?  Sure!  This is perl, it's supposed to 
# be fun.  ;)

sub purldoc_lookup (\$\@) {

  my $regex            =  shift;
  my $original_regex   =  $regex;
  my $target_filename  =  $param{'purldoc_override'} || 'pod/perlfaq.pod';
  my @search_dirs      =  @INC;
  my $results          =  shift;

# There is most likely a much more elegant way to do this search, however
# this works, and it's 2am, so you're welcome to comment all you like either
# to /dev/null or to masque@pound.perl.com.  Patches welcome.  :]

  unless ($param{'purldoc_override'}) {
      for (@search_dirs) { 
          $target_filename = "$_/$target_filename" and last if -e "$_/$target_filename";
      }
  } 

# We don't do -f.  -f would be crazy-long to return.  It'd be easy 
# enough to do, but it should only reply via /msg if implemented.
# Hmm...perhaps it should also be usable as 
# 'tell $who about purldoc -f $function', though that has the 
# potential for abuse.  Perhaps purl should respond '$who wants
# you to ask me about purldoc -f $function,' but that is really
# pretty lame (and likely to be ignored.)  Ah well.  Reserved for
# future use.

  return "No -f for you!  NEXT!" if $regex =~ /^\s*-t?f/i;

# Sanity check on $regex.  We don't want people searching for 'I', etc.
# It was most tempting to add 'HTML' and 'CGI' to the first regex, but
# I overcame the temptation...for now.  ;)

  $regex =~ s/(?:^|\b|\s)(?:\-t?qt?|I|do|how|my|what|which|who|can)\b/ /gi;

# I'm not proud of using the fearsome '.*?' here, but that leading and
# trailing whitespace MUST GO!  IT ALL MUST GO!  WE'LL MAKE ANY DEAL!
# IT'S CRAAAAAAAAAAAAAAAAAAZY MASQUE'S USED REGEX EMPORIUM!  COME ON
# DOWN!  WE'LL CLUB A SEAL TO MAKE A BETTER DEAL!  (Weird Al, UHF)++ 

  $regex =~ s/^\s*(.*?)\s*$/$1/;
  
# We're pretty picky about the regex.  Currently there are no helpful 
# two-letter strings in perlfaq (with the possible exception of 'do', 
# which is being filtered for other reasons) so we require the length
# to be above that, and also we only want letters of the alphabet, 
# thanks.  

  return "\'$original_regex\' isn't a good purldoc search string." unless $regex =~ /^[A-Za-z ]+$/ and length $regex > 2;

  open PURLDOC, "<$target_filename" or return "Sorry, guys.  I can't open perlfaq right now.";

# ACHTUNG!  THE FOLLOWING CODE IS WILDLY INEFFICIENT!  HAVE A CAPS LOCKY DAY.

  my $chapter;
  my $versecount;

  while (<PURLDOC>) {
      last if /^=head1 Credits/;
      $chapter = $1 and $versecount = 0 if /^=item L<(\w+\d)/;
      if (s/=item \* //) { 
          chomp;
          $versecount++;
          push(@$results, "$chapter, question $versecount: $_") if /$regex/i;
      }
  }
  return "No matches for keyphrase '$regex' found." unless scalar @$results;
}
1;