[bkuhn@ebb.org: sluggish behavior in cperl-mode on a large file (included)]

* [bkuhn@ebb.org: sluggish behavior in cperl-mode on a large file (included)]
@ 2007-02-22  7:19 Richard Stallman
  2007-02-23  5:08 ` sluggish behavior in cperl-mode on a large file (included) Stefan Monnier
  0 siblings, 1 reply; 5+ messages in thread
From: Richard Stallman @ 2007-02-22  7:19 UTC (permalink / raw)
  To: emacs-devel

Can someone please take a look at this?
There may be nothing we can do now,
but it is also possible that this is a dumb bug that
we could easily fix.  We should check for that possibility
before postponing this.

------- Start of forwarded message -------
From: bkuhn@ebb.org (Bradley M. Kuhn)
To: bug-gnu-emacs@gnu.org
Date: Tue, 20 Feb 2007 12:56:10 -0500
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="=-=-="
Subject: sluggish behavior in cperl-mode on a large file (included)
Reply-To: bkuhn@ebb.org
X-Spam-Status: No, score=0.0 required=5.0 tests=none autolearn=failed 
	version=3.0.4

- --=-=-=

I am running emacs-snapshot from debian, dated 2006-12-18.  If you think
running a newer version might address this problem, I'm willing to give it
a try, let me know.

My Version string indicates:

  GNU Emacs 22.0.91.1 (i486-pc-linux-gnu, X toolkit, Xaw3d scroll bars) of
  2007-01-11 on hughes, modified by Debian

Attached please find a file called "Time.pm".  This is an approximately
1,000 perl file.

I have noticed that editing it is extremely slow in cperl-mode with
font-lock on.  Doing the equivalent editing in 21 is not so sluggish.   The
following operations should show how slow it is, even on a computer where
Emacs runs very quickly:

  emacs --no-init Time.pm

  In the *scratch* buffer, evaluate the following settings:

  (setq cperl-lock t)
  (setq cperl-electric-lbrace-space t)
  (setq cperl-electric-linefeed t)
  (setq cperl-info-on-command-no-prompt nil)
  (setq cperl-clobber-lisp-bindings t)

Switch back to Time.pm.  and M-X cperl-mode <RET>

Then simply go into one of the sub's and try to tab over and type '<TAB>
if (' and it is very slow.  Another way to see it is scrolling up and down
a lot in succession.

This is definitely a new occurrence.  I've been working on this file since
late 2005, always in Emacs, always with these settings in cperl-mode.  In
Emacs 21, and some earlier snapshots editing the same code, I don't have
this problem.

I notice from elp analysis on cperl- while doing a few quick edits that
the font-lock functions are taking up the most time:

cperl-font-lock-fontify-region-function    18          5.8983649999  0.3276869444
cperl-find-pods-heres                      150         1.2057410000  0.0080382733
cperl-fontify-syntaxically                 44          1.2000600000  0.0272740909
cperl-electric-rparen                      1           0.68433       0.68433
cperl-fontify-update                       18          0.325133      0.0180629444

So, obviously it's font lock related.

I should note that this file has some rather long heredocs, and I notice
that cperl-find-pods-heres is taking up a lot of the time.  I tried the
following settings to see if it sped things up but it didn't help :

          (setq cperl-regexp-scan nil)
          (setq cperl-pod-here-fontify nil)
          (setq cperl-pod-here-scan nil)

   -- bkuhn

- --=-=-=
Content-Type: text/x-perl
Content-Disposition: inline; filename=Time.pm

# Copyright (C) 2005,2006,2007, Software Freedom Law Center, Inc.
#  Licensed under GPL, Version 2 or any later version

package Bot::BasicBot::Time;

use warnings;
use strict;

use base qw(Bot::BasicBot);

use Date::Manip;

use SFLC::TimeTracker::Input;
use SFLC::TimeTracker::Entry;
use SFLC::TimeTracker::Question;
use SFLC::TimeTracker::DB;
use SFLC::TimeTracker::Reports;

use SFLC::TimeTracker::Output::DeleteEntry;
use SFLC::TimeTracker::Output::Entry;

use Lingua::EN::Inflect qw ( PL PL_N PL_V);

use String::Approx 'amatch';

use Date::Manip;
use IO::File;
use POSIX;

my $NOW;
my $SHORTEN_LINE_FOR_REOUTPUT = 15;

# I was really lame here with these user options.  There has got to be some
# CPAN module, Data::Type for example, that I could use for type validation
#  and error reporting.  When I saw all the prerequesite list for Data::Type,
#  I realized that making a big ugly function that validated the fields was
#  so much easier.
my %USER_OPTIONS;

###############################################################################
srand (time ^ $$ ^ unpack "%L*", `/bin/ps axww | /bin/gzip`);
sub myrand ($$) {
  my($min, $max) = @_;
  my $tries = 10;

  my $cnt = 0;
  my $randNum;
  my $val;
  foreach my $file ('/dev/random', '/dev/urandom') {
    sysopen(RANDOM, $file, O_NONBLOCK|O_RDONLY)
      || warn "You have no $file: $!!";

    $val = undef;
    while ( (not defined ($val = sysread(RANDOM, $randNum, 4)) )
            and $cnt < $tries) { $cnt++;}
    close RANDOM;
    last if ($cnt < $tries and defined $val and $val == 4);
  }
  if ($cnt >= $tries or not defined $val or $val != 4) {
    $randNum = int(rand($max-$min+1)) + $min;
  } else {
    $randNum =  (unpack("I", $randNum) % ($max-$min+1)) + $min;
  }
  return $randNum;
}
###############################################################################
# FIXME: This should be a utility function somewhere
sub FindMinMatch ($@) {
  my($given, @candidates) = @_;

  # No choices mean no matches
  return @candidates if @candidates <= 0;

  my $approxVal = 0;
  my @matches;
  while (@matches == 0  and ++$approxVal < 60) {
    (@matches) = amatch($given, ['i', "${approxVal}%"], @candidates);
  }
  print "APPROXED TO: $approxVal\n";
  print "giving matches: $given for candidates, ", join(",", @matches), "\n";
  return @matches;
}
###############################################################################
sub UpdateNow {

  $NOW = ParseDate(POSIX::strftime("%a,  %d  %b  %Y  %H:%M:%S  %z",
                                   localtime()));
  &Date_Init("ForceDate=" . UnixDate($NOW, "%Y-%m-%d-%H:%M:%S"));

  # FIXME: This is a bit nasty, but the only way to be assured that the
  # date delta routines work properly.  The should always be operating on
  # the date the bot currently thinks it is.  I want to avoid a few second
  # drift during processing.

}

# added this POE just to get OBJECT and KERNEL barewords defined and working
use POE::Kernel;
use POE::Session;
use POE::Wheel::Run;
use POE::Filter::Line;
use POE::Component::IRC;

my $VERBOSE_LOGS = 1;

our $DATABASE;

use Unix::Syslog qw(:subs);
use Unix::Syslog qw(:macros);
use Carp;

{
  my $PAGE_EMAIL = '6463617006@tmomail.net';
  my %messageHistory;

  sub WarnLog ($) {
    my($message) = @_;

    syslog LOG_INFO, $message;

    my $lastTime = $messageHistory{$message};

    my $sendIt = 0;
    if (not defined $lastTime) {
      $sendIt = 1;
    } else {
      my $err;
      my $sinceLast = DateCalc($lastTime,"+ 10 minutes",\$err);
      $sendIt = 1 if ($NOW gt $sinceLast);
    }
    if ($sendIt) {
      open(SENDMAIL, "|/usr/sbin/sendmail -f root\@softwarefreedom.org -t");
      print SENDMAIL "To: $PAGE_EMAIL\nFrom: root\@softwarefreedom.org\n",
      "Subject: IRC,TIM\n\n$message\n.\n";
      close(SENDMAIL);
      if ($? != 0) {
        syslog LOG_INFO, "Unable to perform sendmail: $!";
      } else {
        $messageHistory{$message} = $NOW;
      }
    }
  }
}
###############################################################################
sub setOption {
  my($self, $userHandle, $line) = @_;

  return "I cannot understand your SET command paramaters of $line"
    unless $line =~ /^\s*(\S+)\s+(\S+)\s*$/;
  my($opt, $value) = ($1, $2);

  my @matches = FindMinMatch($opt, keys %USER_OPTIONS);

  if (@matches <= 0) {
    return "Cannot find help for option, \"$opt\"";
  }
  $opt = $matches[0];

  if ($USER_OPTIONS{$opt}{type} eq "boolean") {
    if ($value =~ /(?:ye*s*|1|tr?u?e?)/i) {
      $value = 1;
    } elsif ($value =~ /(?:n+o*|0|fa?l?s?e?)/i) {
      $value = 0;
    } else {
      return "$opt is of type boolean and $value is not a boolean value.";
    }
  } elsif ($opt eq "categoryParser") {
    @matches = FindMinMatch($value, qw/AdminAssume BasicLawyer Assistant CTO Press/);
    if (@matches <= 0) {
      return "$value is not a valid value for $opt."
    }
    $value = $matches[0];
  } else {
    return "Woah, REPORT THIS: unknown type of $opt of " .
      "$USER_OPTIONS{$opt}{type}.";
  }
  my $oldVal = $DATABASE->getUserConfigValue($userHandle, $opt);
  my $newVal = $DATABASE->setUserConfigValue($userHandle, $opt, $value);

  return "Changed value of \"$opt\" from \"$oldVal\" to \"$newVal\"";
}
###############################################################################
# Argh: FIXME: copied this from Lawyer.pm, we need a place for utility
# functions!
# Note I do a "noaliases" here, whereas it's with aliases in Lawyer.pm
sub _lookupClientHash ($) {
  my($self) = @_;
  my(@clientCats) = $DATABASE->getCategoryLevelNoAliases("/legal/client");

  my %clients;

  foreach my $cat (@clientCats) {
    croak "bad client entry, \"$cat\", in database"
      unless $cat =~ m%^/legal/client/([^/]+)(.*)$%i;
    my($client, $matter) = ($1, $2);
    $matter =~ s%^/*%%;
    $matter = "general" if  not defined $matter or $matter =~ /^\s*$/;
    $clients{$client} = [] unless defined $clients{$client};
    push(@{$clients{$client}}, $matter);
  }
  return %clients;
}
###############################################################################
sub listFunction {
  my($self, $userHandle, $line) = @_;

  return "I cannot understand your LIST command paramaters: \"$line\""
    unless $line =~ s/^\s*(\S+)\s*//;
  my($type) = ($1);

    return <<LEGAL_FOOL
LIST legal does not do anything; the output of it would be so messy it would be useless.  You probably want "list matters in CLIENT" or "list clients".
Ask for \"help list\" if you are confused.
LEGAL_FOOL
  if ($type eq "legal");

  my @matches = FindMinMatch($type, qw/alias admin clients matters tech/);
  if (@matches <= 0) {
    return "Unknown LIST command argument \"$type\"";
  }
  $type = $matches[0];
  print "TYPE is $type\n";
  if ($type eq "admin" or
      ($type eq "matters" and
       $line =~ s/^\s*(?:(?:in|for|on|with)\s+)*\s*adm?i?n?\s*//i)) {
    my(@admins) = $DATABASE->getCategoryLevelNoAliases("/admin");
    @admins = grep  s%^\s*/admin/%%i, @admins;
    return "Sub" . PL_N('category', scalar @admins) .
      " under /admin: " . join(", ", sort {$a cmp $b} @admins);
  } elsif ($type eq "tech" or
      ($type eq "matters" and
       $line =~ s/^\s*(?:(?:in|for|on|with)\s+)*\s*te?ch\s*//i)) {
    my(@tech) = $DATABASE->getCategoryLevelNoAliases("/tech");
    @tech = grep  s%^\s*/tech/%%i, @tech;
    return "Sub" . PL_N('category', sort { $a cmp $b} scalar @tech) .
      " under /tech: " . join(", ", @tech);
  } elsif ($type eq "clients") {
    my(%clients) = $self->_lookupClientHash();
    return PL("Client", scalar keys %clients) . " " .
      PL_V("is") . ": " . join(", ", sort { $a cmp $b } keys %clients);
  } elsif ($type eq "matters") {
    return "a \"list matters\" request should be followed by the client name."
      unless $line =~ s/^\s*(?:(?:in|for|on|with)\s+)*\s*(\S+)\s*//i;
    my $client = $1;
    my(%clients) = $self->_lookupClientHash();
    my $answer = "";
    if (not defined $clients{$client}) {
      my(@cliMatch) = FindMinMatch($client, keys %clients);
      if (@cliMatch <= 0) {
        return "Requested client, \"$client\" is unknown."
      } else {
        $answer .= "Client, \"$client\" is unknown.  " .
          "Maybe you meant client, \"$cliMatch[0]\"?  ";
        $client = $cliMatch[0];
        print $answer;
      }
    }
    my $num = scalar @{$clients{$client}};
    return $answer . PL("Matter", $num) . " in $client " . PL_V("is", $num) .
      ": " . join(", ", sort { $a cmp $b } @{$clients{$client}});
  } elsif ($type eq "alias") {
    my $db = $DATABASE;
    my(@aliases) = $db->getCategoryAliasList($userHandle);
    my $cnt = scalar(@aliases);
    my $answer = "You have $cnt " . PL_N("alias", $cnt).  ".";
    if ($line !~ /^\s*$/) {
      $line = "/" . join("/", split(/\s+/, $line));
      my $handle = $db->getCategoryHandleForUserHandle(
                                                $line, $userHandle);
      $answer .= (defined $handle) ?
        ("   $line is aliased to " . $db->getCategoryName($handle))
          : "  $line is not a valid alias.";
    }
    return $answer;
  }  else {
    return "REPORT_THIS:  Somehow I got to somewhere I shouldn't be.";
  }
}
###############################################################################
sub _parseStartEnd {
  my($self, $line) = @_;

  my %date;
  ($date{start}, $date{end}) = split(/\s+(?:to|thro?ug?h?|until)\s+/i, $line);

  $date{end} = $date{start}
    if (not defined $date{end} or $date{end} =~ /^\s*$/);

  foreach my $day (qw/start end/) {
    $date{$day} = $NOW if (not defined $date{$day});
    $date{$day} = ParseDate($date{$day});
    $date{$day} = undef if defined $date{$day} and $date{$day} =~ /^\s*$/;
  }
  return %date;
}
###############################################################################
sub statusFunction ($$$) {
  my($self, $userHandle, $line) = @_;

  my $verbose = ($line =~ s/^\s*ve?r?b?o?s?e?(?:\s+|$)//i);
  $line =~ s/^\s*fro?m//i;
  $verbose = ($line =~ s/^\s*ve?r?b?o?s?e?(?:\s+|$)//i) if not $verbose;

  my $email = ($line =~ s/^\s*ema?i?l(?:\s+|$)//i);
  $line =~ s/^\s*fro?m//i;
  $email = ($line =~ s/^\s*ve?r?b?o?s?e?(?:\s+|$)//i) if not $email;

  my $noteFilter;
  if ($line =~ s/no?te?:\"?\s*(.+)\"?\s*$//) {
    $noteFilter = $1;
  }
  my(%date) = $self->_parseStartEnd($line);
  return ("Unable to parse start date in \"$line\" (Maybe you have arguments in the wrong order?).") if not defined $date{start};
  return ("Unable to parse end date in \"$line\".") if not defined $date{end};

  my(@answers) = SFLC::TimeTracker::Reports::QuickSummary($DATABASE,
                                 $userHandle, $date{start}, $date{end},
                                 $verbose, $email, $NOW, $noteFilter, 1);
  return @answers;
}
###############################################################################
sub detailFunction ($$$) {
  my($self, $userHandle, $line) = @_;

  my(%date) = $self->_parseStartEnd($line);
  return ("Unable to parse start date in \"$line\"") if not defined $date{start};
  return ("Unable to parse end date in \"$line\".") if not defined $date{end};

  my $botName = $self->nick;

  SFLC::TimeTracker::Reports::Detail
        ($DATABASE, $userHandle, $date{start}, $date{end}, 'ALL', 'ALL',
         "$userHandle\@softwarefreedom.org", <<NOTE_FOR_EMAIL
This is the report that you requested from $botName in IRC correspondence.
NOTE_FOR_EMAIL
);
  my $startPretty = UnixDate($date{start}, '%F');
  my $endPretty = UnixDate($date{end}, '%F');
  return ("Your detail report " . ( ($startPretty eq $endPretty) ?
             "for $startPretty" :
             "for the dates from $startPretty to $endPretty (inclusive)" ) .
              " has been emailed to you.");
}
###############################################################################
sub deleteFunction {
  my($self, $userHandle, $line, $timeStamp) = @_;

  my($category, $date, $newDate);

  if ($line =~ /^\s*(\d{10,10}\:\d{2,2}:\d{2,2}\-\d+)\s*/) {
    my $id = $1;
    # This is straight-up entry ID, find it directly

    my $entry = $DATABASE->getEntryById($userHandle, $id);

    if (not defined $entry) {
      return new Tree::Simple(
           new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "UNPARSEABLE", type => "",
                         string => 
             "\"$id\" is not a valid entry ID for $userHandle.  Cannot DELETE.",
             edge => 'proceed')))
    }
    my $date = ParseDate($entry->get('dateOccured'));
    $entry->remove;

    my $entryOutput = new SFLC::TimeTracker::Output::DeleteEntry(
                                  date => $date,
                                  userHandle => $userHandle);
    $entryOutput->set('entries', [$entry]);
    return new Tree::Simple(
              new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "DONE", type => "",
                         string => 
                              $entryOutput->prettyPrintIRC($NOW),
             edge => 'proceed')));
  }

  $date = "last" if ($line =~ s/\s*la?st$//i);
  ($category, $newDate) = split(/\s+(?:on|at|for|du?ri?ng)\s+/i, $line);
  $date = $newDate unless (defined $date);

  return new Tree::Simple(
           new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "UNPARSEABLE", type => "",
                         string => 
             "I cannot understand your DELETE command paramaters: \"$line\"",
             edge => 'proceed')))
    unless defined $date and $date !~ /^\s*$/
                and ( (defined $category  and $category !~ /^\s*$/)
                                    or $date eq "last");

  if ($date ne "last") {
    my $normalizedDate = ParseDate($date);
    return new Tree::Simple(
           new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "UNPARSEABLE", type => "",
                         string => 
             "\"$line\" does not contain a valid date.  Cannot DELETE.",
             edge => 'proceed')))
      if (not defined $normalizedDate or $normalizedDate =~ /^\s*$/);
    $date = $normalizedDate;
    print "DELETE: Normalized date to $date cateogry is $category\n";
  }

  if ($date eq "last" and $line =~ /^\s*$/) {
    my $entry = $DATABASE->getLastEntry($userHandle);

    $entry->remove;
    my $entryOutput = new SFLC::TimeTracker::Output::DeleteEntry(
                                  date => $date, userHandle => $userHandle);
    $entryOutput->set('entries', [$entry]);
    return new Tree::Simple(
              new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "DONE", type => "",
                         string => 
                              $entryOutput->prettyPrintIRC($NOW),
             edge => 'proceed')));
  }
  my $entryOutput = new SFLC::TimeTracker::Output::DeleteEntry(
                                  date => $date, userHandle => $userHandle);

  my $parser = new SFLC::TimeTracker::Input::CategoryParser(
                  $DATABASE->getUserConfigValue($userHandle, 'categoryParser'),
                                                  userHandle => $userHandle);

  my $promptString = "Delete entry";
  $promptString = "Delete last entry" if $date eq 'last';
  # FIXME date FORMAT option
  my $pretty = UnixDate($date, '%b %E');
  $promptString = "Delete entry (or entries) on $pretty"
    if (defined $pretty and $pretty !~ /^\s*$/);

  my($resolutionTree, $entryResolver) =   $parser->parse($promptString,
                                                         $category, $timeStamp);
  if (not defined $entryResolver and not defined $resolutionTree) {
    return new Tree::Simple(
              new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                        object => new SFLC::TimeTracker::Output::Statement(
                         status => "UNPARSEABLE", type => "",
                         string => 
            "REPORT THIS: strangly, I can't handle this delete request",
             edge => 'proceed')));
  }
  $entryResolver->addEntry($entryOutput);
  return $resolutionTree;
}
###############################################################################
sub createFunction {
  my($self, $userHandle, $line) = @_;

  return "I cannot understand your CREATE command paramaters: \"$line\""
    unless $line =~ s/^\s*(\S+)\s+//;
  my($type) = ($1);

  my @matches = FindMinMatch($type, qw/admin matter client tech/);
  if (@matches <= 0) {
    return "Unknown list command argument \"$type\"";
  }
  $type = $matches[0];

  $line =~ s/\s+$//;

  if ($type eq "admin") {
    my $newCatString = "/admin/" . join("/", split(m%[\s:\.]%, $line));
    $newCatString = "\L$newCatString\E";
    my(@admins) = $DATABASE->getCategoryLevel($userHandle, "/admin");
    my %admins;  @admins{@admins} = @admins;
    if (defined $admins{$newCatString}) {
      return "The category, $newCatString, already exists.";
    }
    my $cat = new SFLC::TimeTracker::Category(userHandle => $userHandle,
                                          name => $newCatString);
    return "Created new category " . $cat->prettyPrint() . "\n";
  } elsif ($type eq "client") {
    return "Client names must single words and be all alphanumeric characters."
      unless $line =~ /^\s*([A-Za-z0-9]+)\s*$/;
    my $client = "\L$1\E";
    my(%clients) = $self->_lookupClientHash();
    if (defined $clients{$client}) {
      return "The client, $client, already exists.";
    }
    my $genCat = new SFLC::TimeTracker::Category(userHandle => $userHandle,
                                          name =>
                                              "/legal/client/$client/general");
    my $pressCat = new SFLC::TimeTracker::Category(userHandle => $userHandle,
                                          name =>
                                              "/legal/client/$client/press");
    return "Created new client, $client, and categories: " . $genCat->prettyPrint() .
       " and " . $pressCat->prettyPrint() . ".\n";
  } elsif ($type eq "matter") {
    return "Client names must single words and be all alphanumeric characters."
      unless $line =~ s/\s+(?:(?:in|for|on|with)\s+)*([A-Za-z0-9]+)\s*$//;
    my $client = "\L$1\E";
    my(%clients) = $self->_lookupClientHash();
    return "Requested client, \"$client\" is unknown."
      unless defined $clients{$client};
    return "Matter names must single words and be all alphanumeric characters."
      unless $line =~ s/^\s*([A-Za-z0-9]+)\s*$//i
        or ($client eq "fsf" and
        $line =~ s%^\s*\s*(gplv3/[A-Za-z0-9]+)\s*$%%i);
    my $newMatter = "\L$1\E";
    my %matters; @matters{@{$clients{$client}}} = @{$clients{$client}};
    if (defined $matters{$newMatter}) {
      return "Matter, $newMatter, in client, $client, already exists.";
    }
    my $cat = new SFLC::TimeTracker::Category(userHandle => $userHandle,
                                          name =>
                                         "/legal/client/$client/$newMatter");
    return "Created new matter, $newMatter, in client, $client, "
       . "yielding category " . $cat->prettyPrint() . "\n";
  }  else {
    return "REPORT_THIS:  Somehow I got to somewhere I shouldn't be.";
  }
}
###############################################################################
sub aliasFunction ($$$$) {
  my($self, $userHandle, $line, $doUnalias) = @_;

  if ($doUnalias) {
    return "The command should be: \"unalias EXISTING_ALIAS\"\n"
      unless ($line =~ /^\s*(\S+)\s*$/);
    my $oldAlias = $1;
    my $oldVal = $DATABASE->unsetCategoryAlias($userHandle, $oldAlias);
    my $cat;
    $cat = $DATABASE->getCategory($oldVal) if defined $oldVal;
    return (not defined $cat) ?
      "Found no existing alias of $oldAlias" :
      ("alias $oldAlias no longer refers to " . $cat->prettyPrint());
  }
  return "The command should be: \"alias NEW_ALIAS EXISTING_CATEGORY\"." .
         "  Note that both NEW_ALIAS and EXISTING_CATEGORY cannot have spaces"
    unless $line =~ (/^\s*(\S+)\s+(\S+)\s*$/);
  my($newAlias, $existingCat) = ("\L$1\E", "\L$2\E");
  my $category = $DATABASE->categoryAliasLookup($userHandle, $existingCat);
  return "The category, $existingCat, does not exist."
    unless (defined $category);
  $DATABASE->setCategoryAlias($userHandle, $newAlias, $category);
  my $cat = $DATABASE->getCategory($category)->prettyPrint();
  return "$newAlias now refers to $existingCat" .
    ( ($cat eq $existingCat) ? "" : " (aka $cat)") . ".";

}
###############################################################################
sub init {
    my $self = shift;

    carp "a database DBM file path is needed for Time.pm"
      unless defined $self->{dbPath};
    return 0 unless defined $self->{dbPath};

    $DATABASE = 
      new SFLC::TimeTracker::DB("MLDBM", "$self->{dbPath}/time-data.mldbm",
                                       "$self->{dbPath}/pending-time.mldbm");

    SFLC::TimeTracker::Entry::Initialize($DATABASE);
    SFLC::TimeTracker::Question::Initialize($DATABASE);
    SFLC::TimeTracker::Input::Initialize($DATABASE);

    $self->{parser} = new SFLC::TimeTracker::Input($DATABASE);

    $self->{greeted} = {};

    $self->{endTimeAskDelta} = ParseDateDelta("+6 hours");
    $self->{repeatAskDelta} = ParseDateDelta("+2 minutes");

    my $botName = $self->nick;

    %USER_OPTIONS = ( categoryParser => { type => 'enum',
                                         help => <<END_CAT_HELP
Your categoryParser is the method by which $botName interacts with you
when the category you have chosen for a time entry cannot be immediately
determined.  You probably do not want to change this unless you really know
what you are doing.
END_CAT_HELP
},
                     speakWhenSpokenTo => { type => 'boolean',
                                            help => <<END_SPEAK_HELP
When set to a true value, $botName will never speak to you unless you have
addressed it.  In other words, you must say "${botName}: " when you want
to tell something to ${botName} in channel (or send a private message).
END_SPEAK_HELP
},
                  alwaysAnswerPrivate =>  { type => 'boolean',
                                            help => <<END_PRIV_HELP
When set to a true value, $botName will never speak to you on a channel.
Instead, $botName will always speak to you in private IRC messages, regardless
of how you communicated with it originally.
END_PRIV_HELP
});

    $| =1;
    select(STDERR); $| =1; select(STDOUT);
    return 1;
}
###############################################################################
my %shameData = ();

sub SetupShameData ($$) {
  my ($weekNumber, $dayOfWeek) = @_;

  if ($dayOfWeek eq "Tuesday") {
    if (keys %{$shameData{$weekNumber}} <= 0) {
      my @users = $DATABASE->getUserList();
      foreach my $user (@users) {
        $shameData{$weekNumber}{$user} = {};
        my $seconds = myrand(0, 6 * 60 * 60);
        $shameData{$weekNumber}{$user}{when}  =
          DateCalc(ParseDate("today at 11am"), "+ $seconds seconds");
      }
    }
    my $startDate = ParseDate("1 week ago Monday at 00:00");
    my $endDate = ParseDate("last Sunday at 23:59");

    foreach my $user (keys %{$shameData{$weekNumber}}) {
      my @entries = $DATABASE->getEntriesInDateRange('main',
                                      $user, $startDate, $endDate);
      my $total = 0.0;
      foreach my $entry (@entries) {
        $total += Delta_Format($entry->get('amountTime'), 0, "%hd");
      }
      $shameData{$weekNumber}{$user}{total} = $total;
    }
  }
}
my $CURRENT_TIM_TOPIC = "";
my $SAVED_TOPIC = "";
my $REMOVED_TIM_TOPIC = "";
sub shame ($$$$) {
  my($self, $weekNumber, $userList, $channel) = @_;

  my %baddies;
  foreach my $user (@{$userList}) {
    my $hours = $shameData{$weekNumber}{$user}{total};
    $baddies{$user} = $hours if $hours < 32.0;
  }
  my $topic = "All your time entry are belong to tim.  Congratulation !!";

  if ( (keys %baddies) > 0) {
    $topic = "Missing hours last week: ";
    foreach my $user (sort {$a cmp $b } keys %baddies) {
      $topic .= sprintf("$user (%d), ", $baddies{$user});
    }
    $topic =~ s/\s*,\s*$//;
  }
  if ($CURRENT_TIM_TOPIC ne $topic
      or $REMOVED_TIM_TOPIC ne $CURRENT_TIM_TOPIC) {
    $CURRENT_TIM_TOPIC = $topic;
    $topic .= " | $SAVED_TOPIC" if defined $SAVED_TOPIC
      and $SAVED_TOPIC !~ /^\s*$/;
    $self->{kernel}->post( $self->{IRCNAME}, 'topic', $channel, $topic);
  }
  foreach my $user (keys %baddies) {
    if (defined $shameData{$weekNumber}{$user}{when} and
        $shameData{$weekNumber}{$user}{when} le $NOW) {
      my $msg = "$user: You have no chance to survive, make your time (entries).";
      $msg .= ($baddies{$user} <= 0.0) ? "  Got no hours for you last week!" :
        sprintf("  Only got %.1f hours for you last week.", $baddies{$user});
      $self->say(channel => $channel, body => $msg);
      delete $shameData{$weekNumber}{$user}{when};
    }
  }
}
###############################################################################
sub tick {
  my ($self) = @_;

  UpdateNow();

  my %chans = $self->channels();
  foreach my $channel (keys %chans) {
    $self->say(channel => $channel,
               body => "We get signal.  Main screen turn on.  " .
               "All your time entry are belong to us.")
      unless defined $self->{greeted}{$channel};
    $self->{greeted}{$channel} = 1;

    my $dayOfWeek = UnixDate($NOW, "%A");
    my $weekNumber = UnixDate($NOW, "%W");
    # Setup this week's data for Shaming, if needed.
    SetupShameData($weekNumber, $dayOfWeek);
    # FIXME: I think this is a hack....Is there a better way to get names?
    my(@users) = keys %{$self->{channel_data}{$channel}};
    print "$NOW: Ticking ", join(@users, ", "), "\n" if $VERBOSE_LOGS;

    if ($dayOfWeek eq "Wednesday" and (keys %{$shameData{$weekNumber}} <= 0) ) {
        $self->{kernel}->post( $self->{IRCNAME}, 'topic', $channel, $SAVED_TOPIC);
        delete $shameData{$weekNumber};
    }

    if ($dayOfWeek eq "Tuesday") {
      my @canonicalUserList;
      foreach my $user (@users) {
        my $userH = $DATABASE->getUserHandle($user);
        next unless (defined $userH);
        push(@canonicalUserList, $userH);
      }
      $self->shame($weekNumber, \@canonicalUserList, $channel);
    }
  }
  if (defined $self->{DIE_AT_TICK} and $self->{DIE_AT_TICK} == 1) {
    $self->{kernel}->post( $self->{IRCNAME}, 'quit',
                           $self->charset_encode($self->quit_message) );
    exit 0;
  }
  return 120;
}
###############################################################################
sub topic {
  my ($self, $mess) = @_;

  $SAVED_TOPIC = $mess->{topic};

  $SAVED_TOPIC =~ s/^(\s*(?:Missing\s*hours\s+(?:last|this)\s+week\s*:|All your time)[^\|]*)(\||$)//i;
  $REMOVED_TIM_TOPIC = $1;
  $REMOVED_TIM_TOPIC = "" unless defined $REMOVED_TIM_TOPIC;
  $REMOVED_TIM_TOPIC =~ s/^\s+//;    $REMOVED_TIM_TOPIC =~ s/\s+$//;
  $SAVED_TOPIC =~ s/^\s+//;    $SAVED_TOPIC =~ s/\s+$//;

}
###############################################################################
sub said {
  my ($self, $mess, $pri) = @_;

  UpdateNow();

  return undef if $self->ignore_nick($mess->{who});

  my $botName = $self->nick;
  my $body = $mess->{body};
  my $wasAddressed = (defined $mess->{address} and $mess->{address} ne "");

  if ($body =~ /(\S+):/) {
    my $anotherAddressed = $1;
    if ($body =~ s/^\s*(?:time?|$botName)(?::|\s+)?\s*//) {
      # Oh, we really were addressed, force the setting
      $wasAddressed = 1;
    } else {
      # If we see an address to some other known user, ignore it by default.
      return undef if (defined
             $self->{channel_data}{$mess->{channel}}{"\L$anotherAddressed\E"});
    }
  }
  my $userHandle = $DATABASE->getUserHandle($mess->{who});
  if (not defined $userHandle) {
    return ("Who is this guy, $mess->{who}, anyway!!?!  I have never heard of him!");
  }

  return undef
    if (not $wasAddressed) and
      $DATABASE->getUserConfigValue($userHandle, 'speakWhenSpokenTo');

  my @answers;
  my(@answersWithEmpties);

  if ($body =~ s/^\s*(pop|push)(?:\s+|$)//i) {
    push(@answersWithEmpties, "pop/push functionality is not currently available.");
  } elsif ($body =~ s/^\s*(un?)?ali?a?s\s+//i) {
    my $val = $1;
    push(@answersWithEmpties, $self->aliasFunction($userHandle, $body,
                                               (defined $val and $val ne "")));
  } elsif ($body =~ s/^\s*cre?a?te?\s+//i) {
    push(@answersWithEmpties, $self->createFunction($userHandle, $body));
  } elsif ($body =~ s/^\s*set\s+//i) {
    push(@answersWithEmpties, $self->setOption($userHandle, $body));
  } elsif ($body =~ s/^\s*(li?s?t|li)\s+//i) {
    push(@answersWithEmpties, $self->listFunction($userHandle, $body));
  } elsif ($body =~ s/^\s*statu?s?(\s+|$)//i) {
    push(@answers, $self->statusFunction($userHandle, $body));
  } elsif ($body =~ s/^\s*de?ta?i?l?s?\s*//i) {
    push(@answers, $self->detailFunction($userHandle, $body));
  } else {
    # Easter eggs:
    if ($userHandle eq "vasile" and $body =~ /stfu/) {
      push(@answersWithEmpties,
           "Please don't curse at me, James.  Besides, I can't shut up!  :)");
    } elsif ($body =~ /love\s+pat/i) {
      $self->emote(channel => $mess->{channel}, who => $mess->{who},
                   body => "curls up in ${userHandle}'s lap and purrs.");
      return undef;
      #end easter eggs
    } elsif ($body =~ /I\s+(?:love|want|like|care\s+for|am\s+(interested|attracted|excited|aroused)\s+(to|in|for|by))\s+(you|$botName)/i) {
      push(@answersWithEmpties,
           "While I respect and admire you, ${userHandle}, I don't think that I am ready for that kind of relationship.  Perhaps tem would be interested instead?  tem's a lot like me, you know...");
      #end easter eggs
    } else {
      (@answersWithEmpties) = $self->TimeSystem($wasAddressed, $pri, 0,
                                                $userHandle, $body);
    }
  }
  foreach my $ans (@answersWithEmpties) {
    $ans = join(" ", split /\n/, $ans);
    push(@answers, $ans) unless not defined $ans or $ans =~ /^\s*$/;
  }

  my $answerChannel = ($DATABASE->getUserConfigValue($userHandle,
                        'alwaysAnswerPrivate')) ? 'msg' : $mess->{channel};
  print "CHANNEL IS: $mess->{channel}\n";
  if (@answers == 0) {
    return $wasAddressed ?  "I'm sorry; I just don't understand." : undef;
  } else {
    $self->say(who => $mess->{who}, address => 1,
               channel => $answerChannel, body => join("  ", @answers));
    return undef;
  }
}
###############################################################################
sub TimeSystem {
  my ($self, $wasAddressed, $pri, $override, $userHandle, $line) = @_;

  my @answers;

  print "$NOW: About to parse: <$userHandle> $line\n";

  if ($userHandle eq "bkuhn" and $line =~ /^you\s+have\s+no\s+chance\s+to\s+survive[\s,:;]+make\s+your\s+time\.?\s*$/) {
    push(@answers, "Somebody set up us the bomb.");
    $self->{DIE_AT_TICK} = 1;
    return @answers;
  }
  if ($line =~ s/^\s*dry[\-\s\_]run\s*:?\s*//i) {
    my $data = $self->{parser}->dryRun($NOW, $userHandle, $line);
    push(@answers, "Internal parse structure would yield: ",
        split(/\n/, Data::Dumper->Dump([$data])));
    return @answers;
  }
  my $tree;

  $tree = $DATABASE->shiftInteractionTree($userHandle);

  my $shortendLine = (length($line) <= $SHORTEN_LINE_FOR_REOUTPUT) ? $line
    : ( (substr($line, 0, $SHORTEN_LINE_FOR_REOUTPUT)) . " ...");

  my $middleOfConversation = <<END_BAD_INPUT
I noticed you said "$shortendLine", which was probably directed at me, but
I can't process it now because we're in the middle of a conversation.
END_BAD_INPUT
;

  my $actionData;
  if (not defined $tree) {
    # Note that we search for delete here, because we don't want to start
    # a delete process unless there are no interaction trees in operation.
    $tree = ($line =~ s/^\s*del(?:e?t?e?)?\s+//i)
      ? $self->deleteFunction($userHandle, $line)
      : $self->{parser}->parseLine($NOW, $userHandle, $line, $wasAddressed);
    $actionData = {};
  } else {
    if ( not $wasAddressed and
        $self->{parser}->checkIfLineIsTime($NOW, $userHandle, $line)) {
      push(@answers, $middleOfConversation);
      $actionData = {userInput => "INVALID DATA"};
    } elsif ($wasAddressed and $line =~ s/^\s*del(?:e?t?e?)?\s+//i) {
      # This extra check for a user asking for a delete in the middle of a
      # conversation is a bit clugy to go right here, but it has to be done
      # somewhere lest we start parsing deletes in the middle of tree work.
      push(@answers, $middleOfConversation);
      $actionData = {userInput => "INVALID DATA"};
    } elsif ($wasAddressed) {
      $actionData = {userInput => $line };
    } else {
      $DATABASE->unshiftInteractionTree($userHandle, $tree);
      $tree = undef;
    }
  }

  my $ans;

   print "Before process: $tree\n";

              $tree->traverse(sub {
                    my ($_tree) = @_;
                    print(
                      ("-" x ($_tree->getDepth() *4)) . $_tree->getNodeValue()->edge . " -- " . $_tree->getNodeValue()->object . "with value " . Data::Dumper->Dump([$_tree->getNodeValue()->object]) . "\n");
                    }) if defined $tree;

  ($tree, $ans) = RecursiveTreeProcess($tree, $actionData);

  $DATABASE->unshiftInteractionTree($userHandle, $tree) if defined $tree;
  push(@answers, @{$ans}) if defined $ans;

#   print "After process: ", (defined $tree) ? $tree : "", "\n";
#              $tree->traverse(sub {
#                    my ($_tree) = @_;
#                    print(
#                      ("-" x $_tree->getDepth()) . $_tree->getNodeValue()->edge . " -- " . $_tree->getNodeValue()->object . "with value " . $_tree->getNodeValue()->object->prettyPrintIRC() . "\n");
#                    }) if defined $tree;

  return @answers;
}
###############################################################################
sub RecursiveTreeProcess {
  my($tree, $actionData) = @_;
  my @answers;

  return ($tree, \@answers) if not defined $tree;

  my $curObject = $tree->getNodeValue->get('object');

  # Perform action on this tree  ..

  $actionData = $curObject->action($actionData);

  # Don't prettyPrint until we've performed the action

  my $outputString = $curObject->prettyPrintIRC($NOW);

  push(@answers, $outputString) unless $outputString =~ /^\s*$/;

  # If we have now reached a leaf, return an empty tree and the answers.
  return(undef, \@answers) if ($tree->isLeaf);

  # If no action was performed, it means that the tree will have to be
  #  evaluated at a later time.  Return the existing tree and any answers
  #  that we got up to this point.

  return ($tree, \@answers) unless (defined $actionData 
                                    and $actionData->{edge} ne "loopback");

  # Otherwise, we need to continue action down the subtrees.
  my(@kids) = $tree->getAllChildren();

  my @subtrees;
  foreach my $kid (@kids) {
    my $node = $kid->getNodeValue;
    # If a child has an edge that was specifically mentioned as one we should
    #  act on by the actionData we received, or if it is a special "proceed" 
    #  node (which means "evaluate no matter what), we recursively evaluate
    #  the subtree.
    if ($node->edge eq $actionData->{edge} or $node->edge eq 'proceed') {
      my($subTree, $ans) = RecursiveTreeProcess($kid, $actionData);
      push(@answers, @{$ans});
      # We have to save a list of defined subtrees here.  This is in
      #  case the child node was not able to fully evaluate its actions.
      push(@subtrees, $subTree) if defined $subTree;
    }
  }
  if (@subtrees == 0) {
    # If we received no defined subtrees, we know that processing of this
    #   tree is complete and we can return an undefined tree.
    print STDERR "  no subtrees on edge value of " ,$actionData->{edge}, "\n";
    $tree = undef;
  } elsif (@subtrees == 1) {
    return($subtrees[0], \@answers);
  } else {
    # Ok, if we have some defined subtrees, it means that action was not
    # complete on them.  We should gather them all up into one Dummy node
    # parent and return that tree for later processing.
    $tree = undef;
    foreach my $subTree (@subtrees) {
      # First, create that dummy node if it has yet to be created.
      $tree = new Tree::Simple(
                new SFLC::TimeTracker::Input::CategoryParser::ResolutionNode(
                    object => new SFLC::TimeTracker::Output::Dummy(
                                  string => "", status => "DUMMY", type => ""),
                    edge => 'proceed'))
        unless defined $tree;
      $tree->addChild($subTree);
    }
  }
  return ($tree, \@answers);
}

###############################################################################
sub help {
  my($self, $mess) = @_;

  my $userHandle = $DATABASE->getUserHandle($mess->{who});
  return "I cannot help you because I don't know you $mess->{who}"
    unless defined $userHandle;

  $mess->{channel} = ($DATABASE->getUserConfigValue($userHandle,
                        'alwaysAnswerPrivate')) ? 'msg' : $mess->{channel};

  my $line = $mess->{body};

  print "line is $line\n";
  $line =~ s/^\s*help//i;

  if ($line =~ s/^\s*set\s*//i) {
    if ($line =~ /^\s*$/) {
      return "The following options can be set: " .
        join(", ", sort keys %USER_OPTIONS) . ".  help set OPTION will give" .
          " you more information on any of these options.";
    }
    my @matches = FindMinMatch($line, keys %USER_OPTIONS);
    if (@matches <= 0) {
      return "Cannot find help for option, \"$line\"";
    } else {
      my $opt = $matches[0];
      my($val, $currentSettings);
                                        ;
      if ($opt eq "categoryParser") {
        $val = '(AdminAssume|BasicLawyer|Assistant|CTO|Press)';
        my $name = $DATABASE->getUserConfigValue($userHandle, 'categoryParser');
          my $parser = new SFLC::TimeTracker::Input::CategoryParser($name,
                                                 userHandle => $userHandle);
          $currentSettings = "  This option is currently set to \"$name\": " 
            . $parser->get('description');
      } else {
        $val = "\U$USER_OPTIONS{$opt}{type}\E_VALUE";
        $currentSettings = "  This option is currently set to " .
          $DATABASE->getUserConfigValue($userHandle, $opt) . ".";
      }
      return "SET $opt $val: " .
        join(" ", split /\n/, $USER_OPTIONS{$opt}{help}) . $currentSettings;
    }
  } elsif ($line =~ s/^\s*list\s*//i) {
    return <<LIST_HELP;
The LIST function can be used five ways:
   list admin:             list all the subcategories in the /admin category.
   list clients:           list all known clients that are in /legal/client/.
   list matters in CLIENT: list all known matters in the client, CLIENT.
   list tech:              list all known matters in /tech.
   list alias ALIAS:     list the category that ALIAS is aliased to.
LIST_HELP
  } elsif ($line =~ s/^\s*cr?e?ate?\s*//i) {
    return <<CREATE_HELP;
The CREATE function can be used three ways:
   create admin ADMIN_SUBCAT: create /admin/ADMIN_SUBCAT as a category.
   create client CLIENT:      create a new client named CLIENT
   create matter MATTER in CLIENT: create a new matter named MATTER for client, CLIENT
CREATE_HELP
  } elsif ($line =~ s/^\s*de?le?t?e?\s*//i) {
    return <<DELETE_HELP;
The DELETE function can be used four ways:
   delete last:             delete the last time entry made.
   delete CATEGORY last:    delete the last time entry made in CATEGORY.
   delete ENTRY_ID:         delete an entry by its specific id number.
   delete CATEGORY on DATE: delete all entries entered on DATE with a category of CATEGORY.
                            Note that DATE can be somewhat free form, and
                            that the category parser will be launched if
                            needed.  The 'on' is particularly significant
                            as it seperates DATE information from CATEGORY.
DELETE_HELP
  } elsif ($line =~ s/^\s*st(?:at|atu|a|tu)s?\s*//i) {
    return <<STATUS_HELP;
The STATUS function can be used three ways:
   status [verbose] [email] [note: RE]:               gives a brief status of current work today.
   status [verbose] [email] DATE [note: RE]:          give a brief status of work done on DATE.
   status [verbose] [email] DATE1 to DATE2 [note RE]: give a brief status of work done on all days from DATE1 to DATE2, inclusive.
Typically, only summary information for each day is given.
If the optional word "verbose" (or any part thereof) appears immediately after the word "status", each entry for each day is printed in detail, giving the actual entry id and note associated with that entry.
If the optional word "email" (or any part thereof) appears immediately after the word "status" (or "verbose"), the report is emailed to you instead of written to you on IRC.
If the optional ending "note: RE" is included with a regular expression (RE), then the results returned will only be those that have a note in the entry that matches the regular expression, RE.
STATUS_HELP
  } elsif ($line =~ s/^\s*de?ta?i?l?s?\s*//i) {
    return <<DETAIL_HELP;
The DETAIL function can be used three ways:
   detail:                  gives a detailed report of current work today.
   detail DATE:             give a detailed report of work done on DATE.
   detail DATE1 to DATE2:   give a detailed report of work done on all days from DATE1 to DATE2, inclusive.
   Since detail reports are so long, they are always emailed automatically; they are never printed back into an IRC window.
DETAIL_HELP
  } elsif ($line =~ s/^\s*un?ali?a?s\s+//i) {
    return <<UNALIAS_HELP;
The UNALIAS function can be used in one way:
   unalias EXISTING_ALIAS: removes a the category alias EXISTING_ALIAS
UNALIAS_HELP
  } elsif ($line =~ s/^\s*ali?a?s\s+//i) {
    return <<ALIAS_HELP;
The ALIAS function can be used in one way:
   alias NEW_ALIAS EXISTING_CATEGORY: creates an alias of NEW_ALIAS for EXISTING_CATEGORY
ALIAS_HELP
  }
  return "commands are: HELP, STATUS, DETAIL, DELETE, SET, ALIAS, LIST, UNALIAS, CREATE.  Otherwise, "
    . "your input is assumed to be a time entry.";
}

1;
__END__
###############################################################################
#
# Local variables:
# compile-command: "perl -I ../../../Bot-BasicBot/lib -I../../../Modules -c Time.pm"
# End:

- --=-=-=
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
bug-gnu-emacs mailing list
bug-gnu-emacs@gnu.org
http://lists.gnu.org/mailman/listinfo/bug-gnu-emacs

- --=-=-=--
------- End of forwarded message -------

^ permalink raw reply	[flat|nested] 5+ messages in thread