Changeset db0ac7e for perlwrap.pm


Ignore:
Timestamp:
May 3, 2008, 12:52:32 PM (16 years ago)
Author:
Alejandro R. Sedeño <asedeno@mit.edu>
Branches:
master, barnowl_perlaim, debian, release-1.10, release-1.4, release-1.5, release-1.6, release-1.7, release-1.8, release-1.9
Children:
feabce2
Parents:
d9337637 (diff), 811ad93 (diff)
Note: this is a merge changeset, the changes displayed below correspond to the merge itself.
Use the (diff) links above to see all the changes relative to each parent.
Message:
Merged revisions 983-1032 via svnmerge from 
file:///afs/sipb.mit.edu/project/barnowl/src/svn/trunk

........
  r985 | nelhage | 2008-03-11 12:38:20 -0400 (Tue, 11 Mar 2008) | 2 lines
  
  Generate less ugly error spew if a module fails to load
........
  r986 | geofft | 2008-03-13 15:56:20 -0400 (Thu, 13 Mar 2008) | 1 line
  
  Added :webzephyr command with keybinding W.
........
  r987 | asedeno | 2008-03-18 23:57:24 -0400 (Tue, 18 Mar 2008) | 2 lines
  
  Fix a race condition in which zephyrs received during init
  are not noticed until the next zephyr after entering the mainloop.
........
  r988 | geofft | 2008-03-19 15:46:43 -0400 (Wed, 19 Mar 2008) | 6 lines
  
  IRC: explicitly include the network (-a $alias) in reply commands.
  
  This may be unnecessary because :irc-msg looks at getcurmsg() if it cannot
  automatically determine the network.
........
  r989 | geofft | 2008-03-21 14:47:51 -0400 (Fri, 21 Mar 2008) | 1 line
  
  syntax error.
........
  r990 | nelhage | 2008-03-26 02:24:26 -0400 (Wed, 26 Mar 2008) | 2 lines
  
  Fix sending jabbers to JIDs beginning with `+'
........
  r994 | nelhage | 2008-03-29 17:02:05 -0400 (Sat, 29 Mar 2008) | 3 lines
  
  Compile zcrypt.c with -w so I don't get all these warnings in my
  compile output whenever I change any headers
........
  r998 | geofft | 2008-03-31 01:59:47 -0400 (Mon, 31 Mar 2008) | 1 line
  
  Implement /me for outgoing IRC messages
........
  r999 | geofft | 2008-03-31 09:58:56 -0400 (Mon, 31 Mar 2008) | 1 line
  
  I think this fixes the resizing bug.
........
  r1000 | nelhage | 2008-03-31 11:29:29 -0400 (Mon, 31 Mar 2008) | 2 lines
  
  Make `svkversion' handle exported trees better
........
  r1001 | nelhage | 2008-03-31 11:52:39 -0400 (Mon, 31 Mar 2008) | 2 lines
  
  Add a makefile rule to support emacs flymake-mode
........
  r1015 | nelhage | 2008-04-04 14:58:45 -0400 (Fri, 04 Apr 2008) | 3 lines
  
  Bind the combinations the iPhone sends for arrow keys [probably other
  terminals, too]
........
  r1018 | shadow | 2008-04-08 13:57:49 -0400 (Tue, 08 Apr 2008) | 2 lines
  
  avoid null pointer dereference if msg is NULL (or a 0 length is claimed)
........
  r1019 | nelhage | 2008-04-09 18:08:26 -0400 (Wed, 09 Apr 2008) | 2 lines
  
  Fix some stupid typos
........
  r1020 | chmrr | 2008-04-09 18:16:02 -0400 (Wed, 09 Apr 2008) | 3 lines
  
   r29300@kohr-ah:  chmrr | 2008-04-09 18:14:37 -0400
    * It's apparently a popular typo
........
  r1022 | asedeno | 2008-04-16 17:05:36 -0400 (Wed, 16 Apr 2008) | 2 lines
  
  Jabber reply bugfix.
  Reported by several people, resolved by arolfe.
........
  r1023 | nelhage | 2008-04-28 23:33:03 -0400 (Mon, 28 Apr 2008) | 3 lines
  
  Initialized merge tracking via "svnmerge" with revisions "735" from 
  svn+ssh://lunatique.mit.edu/mit/barnowl/src/svn/branches/barnowl_unicode
........
  r1024 | nelhage | 2008-04-28 23:33:12 -0400 (Mon, 28 Apr 2008) | 3 lines
  
  Initialized merge tracking via "svnmerge" with revisions "735" from 
  svn+ssh://lunatique.mit.edu/mit/barnowl/src/svn/branches/barnowl_sqlite
........
  r1025 | nelhage | 2008-04-29 01:21:12 -0400 (Tue, 29 Apr 2008) | 2 lines
  
  Clone owl_perl from the sqlite branch because I'm about to make use of it.
........
  r1026 | nelhage | 2008-04-29 01:21:13 -0400 (Tue, 29 Apr 2008) | 4 lines
  
  Initial step of moving styles from the current mishmash of different
  options to a unified object interface.
  No backwards-compatibility support yet.
........
  r1027 | nelhage | 2008-04-29 01:21:15 -0400 (Tue, 29 Apr 2008) | 2 lines
  
  Implement back-compat with old-style owl::format_msg() styles
........
  r1028 | nelhage | 2008-04-29 01:21:16 -0400 (Tue, 29 Apr 2008) | 2 lines
  
  Remove nearly all references to the "basic" style.
........
  r1029 | nelhage | 2008-04-29 01:21:17 -0400 (Tue, 29 Apr 2008) | 2 lines
  
  Support the `style' command again. Note that it is deprecated.
........
  r1031 | nelhage | 2008-04-30 13:29:45 -0400 (Wed, 30 Apr 2008) | 2 lines
  
  Refactor default style code somewhat to be more easily extensible
........
File:
1 edited

Legend:

Unmodified
Added
Removed

  • perlwrap.pm

    r9815e2e r811ad93  
    153153}
    154154$configfile ||= $ENV{HOME}."/.owlconf";
    155 
    156 # populate global variable space for legacy owlconf files
    157 sub _format_msg_legacy_wrap {
    158     my ($m) = @_;
    159     $m->legacy_populate_global();
    160     return &BarnOwl::format_msg($m);
    161 }
    162155
    163156# populate global variable space for legacy owlconf files
    … …  
    692685# Internal startup/shutdown routines called by the C code
    693686
     687sub _load_perl_commands {
     688    # Load builtin perl commands
     689    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
     690                       {
     691                           summary => "creates a new style",
     692                           usage   => "style <name> perl <function_name>",
     693                           description =>
     694                           "A style named <name> will be created that will\n" .
     695                           "format messages using the perl function <function_name>.\n\n" .
     696                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
     697                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
     698                          });
     699}
     700
    694701sub _load_owlconf {
    695702    # load the config  file
    … …  
    702709        if(*BarnOwl::format_msg{CODE}) {
    703710            # if the config defines a legacy formatting function, add 'perl' as a style
    704             BarnOwl::_create_style("perl", "BarnOwl::_format_msg_legacy_wrap",
    705                                    "User-defined perl style that calls BarnOwl::format_msg"
    706                                    . " with legacy global variable support");
    707             BarnOwl::set("-q default_style perl");
     711            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
     712                "BarnOwl::format_msg",
     713                "User-defined perl style that calls BarnOwl::format_msg"
     714                . " with legacy global variable support",
     715                1));
     716             BarnOwl::set("-q default_style perl");
    708717        }
    709718    }
    … …  
    715724
    716725sub _startup {
     726    _load_perl_commands();
    717727    _load_owlconf();
    718728
    … …  
    763773sub format_message($)
    764774{
    765     my $m = shift;
     775    my $self = shift;
     776    my $m    = shift;
     777    my $fmt;
    766778
    767779    if ( $m->is_loginout) {
    768         return format_login($m);
     780        $fmt = $self->format_login($m);
    769781    } elsif($m->is_ping && $m->is_personal) {
    770         return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
     782        $fmt = $self->format_ping($m);
    771783    } elsif($m->is_admin) {
    772         return "\@bold(OWL ADMIN)\n" . indentBody($m);
     784        $fmt = $self->format_admin($m);
    773785    } else {
    774         return format_chat($m);
    775     }
    776 }
    777 
    778 BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
     786        $fmt = $self->format_chat($m);
     787    }
     788    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
     789    return $fmt;
     790}
     791
     792sub should_bold {
     793    my $self = shift;
     794    my $m = shift;
     795    return $m->is_personal && $m->direction eq "in";
     796}
     797
     798sub description {"Default style";}
     799
     800BarnOwl::create_style("default", "BarnOwl::Style::Default");
    779801
    780802################################################################################
    … …  
    787809
    788810sub format_login($) {
     811    my $self = shift;
    789812    my $m = shift;
    790813    return sprintf(
    … …  
    798821}
    799822
     823sub format_ping {
     824    my $self = shift;
     825    my $m = shift;
     826    return "\@b(PING) from \@b(" . $m->pretty_sender . ")\n";
     827}
     828
     829sub format_admin {
     830    my $self = shift;
     831    my $m = shift;
     832    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
     833}
     834
    800835sub format_chat($) {
     836    my $self = shift;
     837    my $m = shift;
     838    my $header = $self->chat_header($m);
     839    return $header . "\n". $self->indent_body($m);
     840}
     841
     842sub chat_header {
     843    my $self = shift;
    801844    my $m = shift;
    802845    my $header;
    … …  
    819862    }
    820863    $header .= "  " . time_hhmm($m);
     864    $header .= $self->format_sender($m);
     865    return $header;
     866}
     867
     868sub format_sender {
     869    my $self = shift;
     870    my $m = shift;
    821871    my $sender = $m->long_sender;
    822872    $sender =~ s/\n.*$//s;
    823     $header .= " " x (4 - ((length $header) % 4));
    824     $header .= "(" . $sender . '@color[default]' . ")";
    825     my $message = $header . "\n". indentBody($m);
    826     if($m->is_personal && $m->direction eq "in") {
    827         $message = BarnOwl::Style::boldify($message);
    828     }
    829     return $message;
    830 }
    831 
    832 sub indentBody($)
     873    return "  (" . $sender . '@color[default]' . ")";
     874}
     875
     876sub indent_body($)
    833877{
     878    my $self = shift;
    834879    my $m = shift;
    835880
    … …  
    846891}
    847892
     893package BarnOwl::Style::Basic;
     894our @ISA=qw(BarnOwl::Style::Default);
     895
     896sub description {"Compatability alias for the default style";}
     897
     898BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
     899
    848900package BarnOwl::Style::OneLine;
     901# Inherit format_message to dispatch
     902our @ISA = qw(BarnOwl::Style::Default);
     903
     904use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
     905
     906sub description {"Formats for one-line-per-message"}
     907
     908BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
     909
    849910################################################################################
    850 # Branching point for various formatting functions in this style.
    851 ################################################################################
    852 use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
    853 sub format_message($) {
    854   my $m = shift;
    855 
    856 #  if ( $m->is_zephyr ) {
    857 #    return format_zephyr($m);
    858 #  }
    859   if ( $m->is_loginout ) {
    860     return format_login($m);
    861   }
    862   elsif ( $m->is_ping) {
    863     return format_ping($m);
    864   }
    865   elsif ( $m->is_admin || $m->is_loopback) {
    866     return format_local($m);
    867   }
    868   else {
    869     return format_chat($m);
    870   }
    871 }
    872 
    873 BarnOwl::_create_style("oneline", "BarnOwl::Style::OneLine::format_message", "Formats for one-line-per-message");
    874 
    875 ################################################################################
    876911
    877912sub format_login($) {
     913  my $self = shift;
    878914  my $m = shift;
    879915  return sprintf(
    … …  
    898934sub format_chat($)
    899935{
     936  my $self = shift;
    900937  my $m = shift;
    901938  my $dir = lc($m->{direction});
    … …  
    911948  if ($m->is_personal) {
    912949    $line= sprintf(BASE_FORMAT,
    913                    $dirsym,
    914                    $m->type,
    915                    '',
    916                    ($dir eq 'out'
    917                       ? $m->pretty_recipient
    918                       : $m->pretty_sender));
     950                   $dirsym,
     951                   $m->type,
     952                   '',
     953                   ($dir eq 'out'
     954                    ? $m->pretty_recipient
     955                    : $m->pretty_sender));
    919956  }
    920957  else {
    921958    $line = sprintf(BASE_FORMAT,
    922                     $dirsym,
    923                     $m->context,
    924                     $m->subcontext,
    925                     ($dir eq 'out'
    926                        ? $m->pretty_recipient
    927                        : $m->pretty_sender));
     959                    $dirsym,
     960                    $m->context,
     961                    $m->subcontext,
     962                    ($dir eq 'out'
     963                     ? $m->pretty_recipient
     964                     : $m->pretty_sender));
    928965  }
    929966
    … …  
    931968  $body =~ tr/\n/ /;
    932969  $line .= $body;
    933   $line = BarnOwl::Style::boldify($line) if ($m->is_personal && lc($m->direction) eq 'in');
    934970  return $line;
    935971}
    936972
    937 # Format locally generated messages
    938 sub format_local($)
     973# Format owl admin messages
     974sub format_admin($)
    939975{
     976  my $self = shift;
    940977  my $m = shift;
    941   my $type = uc($m->{type});
    942   my $line = sprintf(BASE_FORMAT, '<', $type, '', '');
     978  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
    943979  my $body = $m->{body};
    944980  $body =~ tr/\n/ /;
    … …  
    9681004}
    9691005
     1006sub style_command {
     1007    my $command = shift;
     1008    if(scalar @_ != 3 || $_[1] ne 'perl') {
     1009        die("Usage: style <name> perl <function>\n");
     1010    }
     1011    my $name = shift;
     1012    my $perl = shift;
     1013    my $fn   = shift;
     1014    {
     1015        no strict 'refs';
     1016        unless(*{$fn}{CODE}) {
     1017            die("Unable to create style '$name': no perl function '$fn'\n");
     1018        }
     1019    }
     1020    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
     1021}
     1022
     1023package BarnOwl::Style::Legacy;
     1024
     1025sub new {
     1026    my $class = shift;
     1027    my $func  = shift;
     1028    my $desc  = shift;
     1029    my $useglobals = shift;
     1030    $useglobals = 0 unless defined($useglobals);
     1031    return bless {function    => $func,
     1032                  description => $desc,
     1033                  useglobals  => $useglobals}, $class;
     1034}
     1035
     1036sub description {
     1037    my $self = shift;
     1038    return $self->{description} ||
     1039    ("User-defined perl style that calls " . $self->{function});
     1040};
     1041
     1042sub format_message {
     1043    my $self = shift;
     1044    if($self->{useglobals}) {
     1045        $_[0]->legacy_populate_global();
     1046    }
     1047    no strict 'refs';
     1048    goto \&{$self->{function}};
     1049}
     1050
    9701051
    9711052# switch to package main when we're done
Note: See TracChangeset for help on using the changeset viewer.