init

local/cgi-bin/CSS/Cleaner.pm

@@ -0,0 +1,152 @@
+#
+# Note:  this is a very early version of a CSS cleaner.  The plan is to eventually
+#        make it a white-listing CSS cleaner (deny by default) with a nice
+#        interface where you can build policy about what's allowed, like
+#        HTML::Sanitize/::Scrub/etc, but for now this is almost a null cleaner,
+#        just parsing and reserializing the CSS, removing two trivial ways to
+#        inject javascript.
+#
+#        The plan now is to integrate this interface into LiveJournal, then improve
+#        this module over time.
+#
+# Note2:  we tried 4 different CSS parsers for this module to use, and all 4 sucked.
+#         so for now this module sucks, until we can find a suitable parser.  for the
+#         record, CSS::Tiny, CSS, and CSS::SAC all didn't work.  and csstidy wasn't
+#         incredibly hot either.  CSS.pm's grammar was buggy, and CSS::SAC had the
+#         best interface (SAC) but terrible parsing of selectors.  we'll probably
+#         have to write our own, based on the Mozilla CSS parsing code.
+
+
+package CSS::Cleaner;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+sub new {
+    my $class = shift;
+    my %opts = @_;
+
+    my $self = bless {}, $class;
+
+    if (defined( $opts{rule_handler} )) {
+        my $rule_handler = $opts{rule_handler};
+        die "rule_handler needs to be a coderef if supplied" unless ref( $rule_handler ) eq 'CODE';
+        $self->{rule_handler} = $rule_handler;
+    }
+
+    if (defined( $opts{pre_hook} )) {
+        my $pre_hook = $opts{pre_hook};
+        die "pre_hook needs to be a coderef if supplied" unless ref( $pre_hook ) eq 'CODE';
+        $self->{pre_hook} = $pre_hook;
+    }
+
+    return $self;
+}
+
+# cleans CSS
+sub clean {
+    my ($self, $target) = @_;
+    $self->_stupid_clean(\$target);
+    return $target;
+}
+
+# cleans CSS properties, as if it were in a style="" attribute
+sub clean_property {
+    my ($self, $target) = @_;
+    $self->_stupid_clean(\$target);
+    return $target;
+}
+
+# this is so stupid.  see notes at top.
+#  returns 1 if it was okay, 0 if possibly malicious
+sub _stupid_clean {
+    my ($self, $ref) = @_;
+
+    my $reduced = $$ref;
+    if (defined( $self->{pre_hook} )) {
+        $self->{pre_hook}->( \$reduced );
+    }
+
+    $reduced =~ s/&\#(\d+);?/chr($1)/eg;
+    $reduced =~ s/&\#x(\w+);?/chr(hex($1))/eg;
+
+    if ($reduced =~ /[\x00-\x08\x0B\x0C\x0E-\x1F]/) {
+        $$ref = "/* suspect CSS: low bytes */";
+        return;
+    }
+
+    if ($reduced =~ /[\x7f-\xff]/) {
+        $$ref = "/* suspect CSS: high bytes */";
+        return;
+    }
+
+    # returns 1 if something bad was found
+    my $check_for_bad = sub {
+        if ($reduced =~ m!<\w!) {
+            $$ref = "/* suspect CSS: start HTML tag? */";
+            return 1;
+        }
+
+        my $with_white = $reduced;
+        $reduced =~ s/[\s\x0b]+//g;
+
+        if ($reduced =~ m!\\[a-f0-9]!i) {
+            $$ref = "/* suspect CSS: backslash hex */";
+            return;
+        }
+
+        $reduced =~ s/\\//g;
+
+        if ($reduced =~ /\@(import|charset)([\s\x0A\x0D]*[^\x0A\x0D]*)/i) {
+            my $what = $1;
+            my $value = $2;
+             if (defined( $self->{rule_handler} )) {
+                return $self->{rule_handler}->( $ref, $what, $value );
+            } else {
+                $$ref = "/* suspect CSS: $what rule */";
+                return;
+            }
+        }
+
+        if ($reduced =~ /&\#/) {
+            $$ref = "/* suspect CSS: found irregular &# */";
+            return;
+        }
+
+        if ($reduced =~ m!</!) {
+            $$ref = "/* suspect CSS: close HTML tag */";
+            return;
+        }
+
+        # returns 1 if bad phrases found
+        my $check_phrases = sub {
+            my $str = shift;
+            if ($$str =~ m/(\bdata:\b|javascript|jscript|livescript|vbscript|expression|eval|cookie
+                |\bwindow\b|\bparent\b|\bthis\b|behaviou?r|moz-binding)/ix) {
+                my $what = lc $1;
+                $$ref = "/* suspect CSS: potential scripting: $what */";
+                return 1;
+            }
+            return 0;
+        };
+        return 1 if $check_phrases->(\$reduced);
+
+        # restore whitespace
+        $reduced = $with_white;
+        $reduced =~ s!/\*.*?\*/!!sg;
+        $reduced =~ s!\<\!--.*?--\>!!sg;
+        $reduced =~ s/[\s\x0b]+//g;
+        $reduced =~ s/\\//g;
+        return 1 if $check_phrases->(\$reduced);
+
+        return 0;
+    };
+
+    # check for bad stuff before/after removing comment lines
+    return 0 if $check_for_bad->();
+    $reduced =~ s!//.*!!g;
+    return 0 if $check_for_bad->();
+    return 1;
+}
+
+1;

local/cgi-bin/Golem.pm

@@ -0,0 +1,94 @@
+#!/usr/bin/perl -w
+
+package Golem;
+
+use strict;
+
+require "$ENV{'LJHOME'}/cgi-bin/Golem/dblib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/Golem/loglib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/Golem/netlib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/Golem/proplib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/Golem/textlib.pl";
+
+# *** LJR apis conversion layer
+#
+# check out
+
+our $on = 1;
+our $counter_prefix = "golem_";
+
+sub get_db {
+  return LJ::get_db_writer();
+}
+
+# Golem tags are not ported to LJR
+sub unset_row_tag {
+	return 1;
+}
+# *** LJR apis conversion layer
+
+sub get_callstack {
+  my $cstack;
+  my $i = 0;
+  while ( 1 ) {
+    my $tfunc = (caller($i))[3];
+    if ($tfunc && $tfunc ne "") {
+      if ($tfunc !~ /\_\_ANON\_\_/ &&
+        $tfunc !~ /.*::get_callstack/) {
+        $cstack .= "\t" . $tfunc . "\n";
+      }
+      $i = $i + 1;
+    }
+    else {
+      last;
+    }
+  }
+  return "\nCallstack:\n" . $cstack . "\n";
+}
+
+sub err {
+  if (ref($_[0])) {
+    my $dbh = shift;
+    $dbh->rollback;
+  }
+
+  my $errstr = shift || "";
+  my $previous_object;
+
+  if (ref($_[0]) eq 'HASH') {
+    $previous_object = shift;
+  }
+
+  if ($previous_object) {
+    $previous_object->{'err'} = 1;
+    $previous_object->{'errstr'} = $errstr . Golem::get_callstack();
+
+    return $previous_object;
+  }
+  else {
+    my %res = (
+      "err" => 1,
+      "errstr" => $errstr . Golem::get_callstack(),
+      );
+  
+    return \%res;
+  }
+}
+
+sub die {
+  my ($message, $suppress_callstack) = @_;
+
+  print STDERR "$message";
+
+  unless ($suppress_callstack) {
+    print STDERR Golem::get_callstack();
+  }
+  else {
+    print "\n";
+  }
+
+  exit 1;
+}
+
+
+1;

local/cgi-bin/Golem/dblib.pl

@@ -0,0 +1,746 @@
+#!/usr/bin/perl -w
+#
+# Generic database routines
+#
+
+
+package Golem;
+use strict;
+
+use Golem;
+
+# courtesy of LiveJournal.org
+sub disconnect_dbs {
+  foreach my $h (($Golem::DB, $Golem::PlanerDB, $Golem::CalendarDB, $Golem::OtrsDB, $Golem::SwerrsDB)) {
+    if ($h) {
+      $h->disconnect();
+      $h = undef;
+    }
+  }
+
+  print STDERR localtime() . " [$$]: closed db connections\n" if $ENV{'GOLEM_DEBUG'};
+}
+
+# build DSN connection string based on database info hashref,
+# courtesy of livejournal.org
+#
+#  $DBINFO = {
+#    'master' => {
+#      'dbname' => "golem_kohts",
+#      'host' => "localhost",
+#      'port' => 3306,
+#      'user' => "root",
+#      'pass' => "",
+#      'sock' => "",
+#      'encoding' => "utf8",
+#    },
+#  };
+#
+sub make_dbh_fdsn {
+  my ($db) = @_;
+  
+  my $fdsn = "DBI:mysql";
+  $fdsn .= ":$db->{'dbname'}";
+  $fdsn .= ";host=$db->{'host'}" if $db->{'host'};
+  $fdsn .= ";port=$db->{'port'}" if $db->{'port'};
+  $fdsn .= ";mysql_socket=$db->{'sock'}" if $db->{'sock'};
+  $fdsn .= "|$db->{'user'}|$db->{'pass'}";
+  
+  return $fdsn;
+}
+
+# test if connection is still available
+# (should check for replication, etc. here)
+#
+sub connection_bad {
+  my ($dbh, $try) = @_;
+  
+  return 1 unless $dbh;
+  
+  my $ss = eval {
+#
+#   $dbh->selectrow_hashref("SHOW SLAVE STATUS");
+#
+#   on a real slave
+#
+# $ss = {
+#          'Skip_counter' => '0',
+#          'Master_Log_File' => 'ararita-bin.882',
+#          'Connect_retry' => '60',
+#          'Master_Host' => 'ararita.lenin.ru',
+#          'Relay_Master_Log_File' => 'ararita-bin.882',
+#          'Relay_Log_File' => 'laylah-relay-bin.323',
+#          'Slave_IO_Running' => 'Yes',
+#          'Slave_SQL_Running' => 'Yes',
+#          'Master_Port' => '3306',
+#          'Exec_master_log_pos' => '17720151',
+#          'Relay_log_space' => '19098333',
+#          'Relay_Log_Pos' => '19098333',
+#          'Last_errno' => '0',
+#          'Last_error' => '',
+#          'Replicate_do_db' => 'prod_livejournal,prod_livejournal',
+#          'Read_Master_Log_Pos' => '17720151',
+#          'Master_User' => 'replication',
+#          'Replicate_ignore_db' => ''
+#        };
+    
+    $dbh->selectrow_hashref("select name from _dbi");
+  };
+  
+  if ($dbh->err && $dbh->err != 1227) {
+    print STDERR localtime() . " [$$]: " . $dbh->errstr . "\n" if $ENV{'GOLEM_DEBUG'};
+    return 1;
+  }
+  
+  if ($ss && $ss->{'name'} ne '??') {
+    return 0;
+  }
+  elsif ($ss && $ss->{'name'} eq '??') {
+    print STDERR localtime() . " [$$]: DBI returned garbage: $ss->{'name'}\n" if $ENV{'GOLEM_DEBUG'};
+    return 1;
+  }
+  elsif (!$ss) {
+    print STDERR localtime() . " [$$]: DBI returned nothing\n" if $ENV{'GOLEM_DEBUG'};
+    return 1;
+  }
+}
+
+# LJR modification; redefined in cgi-bin/Golem.pmGolem.pm
+# so it works correctly with original LJ code
+#
+sub golem_get_db {
+  my ($params, $opts) = @_;
+
+  $opts = {} unless $opts;
+  $params = {} unless $params;
+
+  if ($Golem::DB) {
+    if (! connection_bad($Golem::DB)) {
+      return $Golem::DB;
+    }
+    else {
+      print STDERR localtime() . " [$$]: new connection: was bad\n" if $ENV{'GOLEM_DEBUG'};
+      $Golem::DB->disconnect;
+    }
+  }
+  else {
+    print STDERR localtime() . " [$$]: new connection: had none\n" if $ENV{'GOLEM_DEBUG'};
+  }
+  undef $Golem::DB;
+
+  # DB connection defaults (unless programmer specified them)
+  #
+  $params->{'RaiseError'} = 0 unless defined($params->{'RaiseError'});
+  $params->{'PrintError'} = 1 unless defined($params->{'PrintError'});
+  $params->{'AutoCommit'} = 1 unless defined($params->{'AutoCommit'});
+
+  Golem::die("No Golem::DBINFO master defined")
+    unless $Golem::DBINFO->{'master'};
+
+  my $dbinfo = $Golem::DBINFO->{'master'};
+  my $fdsn = make_dbh_fdsn($dbinfo);
+  
+  $Golem::DB = DBI->connect($fdsn, $dbinfo->{'user'}, $dbinfo->{'pass'}, $params);
+  while (!$Golem::DB && $opts->{'retry_forever'}) {
+    Golem::do_log("database not available, retrying", {"stderr" => 1});
+    sleep 1;
+    $Golem::DB = DBI->connect($fdsn, $dbinfo->{'user'}, $dbinfo->{'pass'}, $params);
+  }
+  Golem::die("Unable to connect to database: " . DBI->errstr)
+    unless $Golem::DB;
+
+  $Golem::DB->do("SET NAMES " . $dbinfo->{'encoding'})
+    if $dbinfo->{'encoding'};
+
+  if (connection_bad($Golem::DB)) {
+    print STDERR "got fresh new bad handle, retrying\n" if $ENV{'GOLEM_DEBUG'};
+    $Golem::DB = undef;
+    $Golem::DB = Golem::get_db();
+  }
+
+  $Golem::default_dc_obj = Golem::get_dc($Golem::default_dc);
+  return $Golem::DB;
+}
+
+sub get_planer_db {
+  my ($params) = @_;
+
+  return $Golem::PlanerDB if $Golem::PlanerDB;
+
+  $params = {RaiseError => 0, PrintError => 1, AutoCommit => 1}
+    unless $params;
+
+  $Golem::PlanerDB = DBI->connect("DBI:Sybase:server=argo3.yandex.ru;database=planer;",
+    "helpdesk", "gkfyshfcnfvfys123", $params);
+
+  return $Golem::PlanerDB;
+}
+
+sub get_calendar_db {
+  my ($params) = @_;
+
+  return $Golem::CalendarDB if $Golem::CalendarDB;
+
+  $params = {RaiseError => 0, PrintError =>1, AutoCommit => 1}
+    unless $params;
+  
+  $Golem::CalendarDB = DBI->connect("DBI:Sybase:server=argo3.yandex.ru;database=momdb;",
+    "staffreader", "cegthgfhjkm678", $params);
+
+  return $Golem::CalendarDB;
+}
+
+sub get_otrs_db {
+  my ($params) = @_;
+
+  return $Golem::OtrsDB if $Golem::OtrsDB;
+
+  $params = {RaiseError => 0, PrintError =>1, AutoCommit => 1}
+    unless $params;
+  
+  $Golem::OtrsDB = DBI->connect("DBI:mysql:database=otrs_utf8:host=casa.yandex.ru:port=3306",
+    "userorder", "xuo9Bahf", $params);
+
+  return $Golem::OtrsDB;
+}
+
+sub get_swerrs_db {
+  my ($params) = @_;
+
+  return $Golem::SwerrsDB if $Golem::SwerrsDB;
+
+  $params = { RaiseError => 0, PrintError => 1, AutoCommit => 1 }
+    unless $params;
+
+  $Golem::SwerrsDB = DBI->connect("DBI:mysql:racktables:localhost:3306", "swerrs", "V7Hl}O]Usr", $params);
+
+  return $Golem::SwerrsDB;
+}
+
+
+sub sth_bind_array {
+  my ($sth, $bound_values) = @_;
+
+  my $i = 0;
+  foreach my $b (@{$bound_values}) {
+    $i++;
+    
+    Golem::die("error binding params")
+      unless $sth->bind_param($i, $b) ;
+  }
+}
+
+# courtesy of LiveJournal.org
+# see also: http://dev.mysql.com/doc/refman/5.0/en/information-functions.html#function_last-insert-id
+#
+sub alloc_global_counter {
+  my ($tag, $recurse) = @_;
+  
+  my $dbh = Golem::get_db();
+  my $newmax;
+
+  # in case name `counter` is already occupied
+  # by some user table
+  my $counter_prefix = "";
+  $counter_prefix = $Golem::counter_prefix
+  	if defined($Golem::counter_prefix);
+	
+  my $rs = $dbh->do("UPDATE ${counter_prefix}counter SET max=LAST_INSERT_ID(max+1) WHERE tag=?", undef, $tag);
+  if ($rs > 0) {
+    $newmax = $dbh->selectrow_array("SELECT LAST_INSERT_ID()");
+    return $newmax;
+  }
+  
+  return undef if $recurse;
+
+  # no prior counter rows - initialize one.
+
+  # if this is a table then trying default id column
+  if ($Golem::SCHEMA_CACHE->{'tables'}->{$tag}) {
+    $newmax = $dbh->selectrow_array("SELECT MAX(id) FROM `$tag`");
+  }
+  else {
+    Golem::die("alloc_global_counter: unknown tag [$tag], unable to get max value.");
+  }
+
+  $newmax += 0;
+
+  $dbh->do("INSERT IGNORE INTO ${counter_prefix}counter (tag, max) VALUES (?,?)",
+    undef, $tag, $newmax) || return undef;
+
+  return Golem::alloc_global_counter($tag, 1);
+}
+
+# get schema table definition,
+# prepare in-memory table structure
+#
+sub get_schema_table {
+  my ($table_name, $opts) = @_;
+
+  return $Golem::SCHEMA_CACHE->{'tables'}->{$table_name}
+    if $Golem::SCHEMA_CACHE->{'tables'}->{$table_name} &&
+      !$opts->{'force'};
+
+  delete($Golem::SCHEMA_CACHE->{'tables'}->{$table_name})
+    if $Golem::SCHEMA_CACHE->{'tables'}->{$table_name};
+
+  $Golem::SCHEMA_CACHE->{'tables'}->{$table_name}->{'fields'} = {};
+  my $t = $Golem::SCHEMA_CACHE->{'tables'}->{$table_name};
+
+  my $dbh = Golem::get_db();
+  Golem::debug_sql("describe `$table_name`");
+  my $sth = $dbh->prepare("describe `$table_name`");
+  $sth->execute();
+  Golem::die("Error describing table [$table_name]: " . $dbh->errstr)
+    if $dbh->err;
+
+  my $select_all_sql = "";
+  while (my $r = $sth->fetchrow_hashref) {
+    my $field_name = $r->{'Field'};
+
+    $t->{'fields'}->{$field_name} = $r;
+
+    if ($r->{'Type'} =~ /^enum\((.+)\)/o) {
+      my $enums = $1;
+      foreach my $etype (split(/,/o, $enums)) {
+        $etype =~ s/'//go;
+        $t->{'fields'}->{$field_name}->{'enum'}->{$etype} = 1;
+      }
+    }
+    
+    if ($r->{'Type'} eq 'timestamp') {
+      $select_all_sql .= "UNIX_TIMESTAMP(`$field_name`) as `$field_name`, ";
+    }
+    else {
+      $select_all_sql .= "`$field_name`, ";
+    }
+
+    if ($r->{'Key'} eq 'PRI') {
+      $t->{'primary_key'}->{$field_name} = 1;
+    }
+  }
+  chop($select_all_sql);
+  chop($select_all_sql);
+
+  $Golem::SCHEMA_CACHE->{'tables'}->{$table_name}->{'select_all_sql'} = $select_all_sql;
+
+  return $Golem::SCHEMA_CACHE->{'tables'}->{$table_name};
+}
+
+# function tells whether field is data field or some special field
+# like host.id (incremented with alloc_global_counter) or
+# like host.last_updated (automatically updated when record is updated)
+# maybe we should filter them by name instead of using db structure hints?
+sub is_data_field {
+  my ($table_name, $field_name, $opts) = @_;
+
+  $opts = {} unless $opts;
+
+  my $table = Golem::get_schema_table($table_name);
+  my $table_fields = $table->{'fields'};
+
+  if ($table_fields->{$field_name}) {
+    if ($table_fields->{$field_name}->{'Default'} &&
+      $table_fields->{$field_name}->{'Default'} eq 'CURRENT_TIMESTAMP' &&
+      !$opts->{'ignore_default_current_timestamp'} ) {
+
+      return 0;
+    }
+
+#    if ($table_fields->{$field_name}->{'Key'} &&
+#      $table_fields->{$field_name}->{'Key'} eq 'PRI') {
+#
+#      return 0;
+#    }
+
+    # we have to distinguish between host.id and host_rackmap.host;
+    # both are PRIMARY keys, but
+    # 1) we shouldn't ever update host.id
+    # 2) we have to update host_rackmap.host with host.id
+    # when creating record corresponding to host record
+    if ($field_name eq "id" && !$opts->{'manual_id_management'}) {
+      return 0;
+    }
+
+    return 1;
+  }
+  else {
+    return 0;
+  }
+}
+
+sub __insert {
+  my ($table_name, $record_hashref, $opts) = @_;
+
+  Golem::die("Severe programmer error: __insert expects table name as first parameter!")
+    unless $table_name;
+  Golem::die("Severe programmer error: __insert expects record hashref as second parameter!")
+    unless ref($record_hashref) eq 'HASH';
+
+  $opts = {} unless ref($opts) eq 'HASH';
+
+  my $dbh;
+  if ($opts->{'dbh'}) {
+    $dbh = $opts->{'dbh'};
+  }
+  else {
+    $dbh = Golem::get_db();
+  }
+
+  $dbh->{'PrintError'} = $opts->{'PrintError'}
+    if defined($opts->{'PrintError'});
+
+  my $sth;
+
+  my $table = Golem::get_schema_table($table_name);
+  my $table_fields = $table->{'fields'};
+
+  # continue only if there's data for the table
+  # or if there's a flag saying we should create
+  # empty record with defaults
+  my $have_data_for_the_table = 0;
+  while (my ($o, $v) = each(%{$record_hashref})) {
+    if (Golem::is_data_field($table_name, $o, $opts)) {
+      $have_data_for_the_table = 1;
+    }
+  }
+  unless ($have_data_for_the_table || $opts->{'create_empty_record'}) {
+    return $dbh;
+  }
+
+  my @record_fields;
+  my @record_values;
+
+  foreach my $o (keys %{$record_hashref}) {
+    # $record_hashref might contain more fields than present in database.
+    # we only choose those which are in db
+    
+    if ($table_fields->{$o} && Golem::is_data_field($table_name, $o, $opts)) {
+      
+      # enum validation
+      if ($table_fields->{$o}->{'enum'}) {
+        Golem::die("Enum [$table_name.$o] value is not specified and doesn't have default value")
+          if !defined($record_hashref->{$o}) && $table_fields->{$o}->{'Default'} eq '';
+
+        Golem::die("Enum [$table_name.$o] can't be [$record_hashref->{$o}]")
+          if $record_hashref->{$o} && !$table_fields->{$o}->{'enum'}->{$record_hashref->{$o}};
+
+        # if they passed empty value for enum
+        # and there's some default -- silently
+        # decide to use it
+        unless ($record_hashref->{$o}) {
+          delete($record_hashref->{$o});
+          next;
+        }
+      }
+      
+      push @record_fields, $o;
+      push @record_values, $record_hashref->{$o};
+    }
+  }
+
+  if ($table_fields->{"id"} && !$opts->{'manual_id_management'}) {
+    if ($record_hashref->{"id"}) {
+      Golem::die("Severe database structure or programmer error: __insert got id [$record_hashref->{'id'}]
+when creating record for table [$table_name]; won't overwrite.\n");
+    }
+
+    $record_hashref->{"id"} = Golem::alloc_global_counter($table_name);
+    
+    # check that id is not taken and
+    # die with severe error otherwise
+    #
+
+    my $t_id = $dbh->selectrow_array("select id from `$table_name` where id = ?",
+      undef, $record_hashref->{"id"});
+    if ($t_id && $t_id eq $record_hashref->{"id"}) {
+      Golem::die("Severe database error: __insert got [$t_id] for table [$table_name] " .
+        "from alloc_global_counter which already exists!\n" .
+        "Probable somebody is populating [$table_name] without Golem::__insert()\n");
+    }
+    
+    push @record_fields, "id";
+    push @record_values, $record_hashref->{"id"};
+  }
+
+  my $sql;
+  my @bound_values;
+
+  $sql = "INSERT INTO `$table_name` ( ";
+  foreach my $o (@record_fields) {
+    $sql = $sql . " `$o`,";
+  }
+  chop($sql);
+
+  $sql .= " ) VALUES ( ";
+
+  my $i = 0;
+  foreach my $o (@record_values) {
+
+    # we represent timestamp datatype as unixtime (http://en.wikipedia.org/wiki/Unix_time)
+    # doing all the conversions almost invisible to the end user
+    #
+    # if the value being written is 0 then we're not using FROM_UNIXTIME(value)
+    # (which generates warnings) just value
+    #
+    if ($table_fields->{$record_fields[$i]}->{'Type'} eq 'timestamp' && $o && $o != 0) {
+      Golem::die("Programmer error: __insert got hashref with invalid data for $table_name.$record_fields[$i] (should be unixtime)")
+        unless $o =~ /^[0-9]+$/o;
+
+      $sql = $sql . "FROM_UNIXTIME(?),";
+    }
+    else {
+      $sql = $sql . "?,";
+    }
+
+    push @bound_values, $o;
+    $i++;
+  }
+  chop($sql);
+  $sql .= " )";
+
+  Golem::debug_sql($sql, \@bound_values);
+
+  $sth = $dbh->prepare($sql);
+  Golem::sth_bind_array($sth, \@bound_values);
+  $sth->execute();
+
+  if ($dbh->err && $dbh->{'PrintError'}) {
+    Golem::do_log("got error [" . $dbh->err . "] [" . $dbh->errstr . "]" .
+      " while executing [$sql] with values (" . join(",", @bound_values) . ")",
+      {'stderr' => 1});
+  }
+
+  return $dbh;
+}
+
+sub __update {
+  my ($table_name, $record_hashref, $opts) = @_;
+
+  Golem::die("Severe programmer error: __update expects table name as first parameter!")
+    unless $table_name;
+  Golem::die("Severe programmer error: __update expects record hashref as second parameter!")
+    unless ref($record_hashref) eq 'HASH';
+
+  $opts = {} unless ref($opts) eq 'HASH';
+
+  my $dbh;
+  if ($opts->{'dbh'}) {
+    $dbh = $opts->{'dbh'};
+  }
+  else {
+    $dbh = Golem::get_db();
+  }
+
+  my $sth;
+
+  my $table = Golem::get_schema_table($table_name);
+  my $table_fields = $table->{'fields'};
+  my $unique_fields_arrayref = [keys %{$table->{'primary_key'}}];
+
+  if ($opts->{'unique_fields'}) {
+    $unique_fields_arrayref = $opts->{'unique_fields'};
+  }
+
+  # continue only if there's data for the table
+  # in the in-memory hash or if there's a flag
+  # saying we should create empty record with defaults
+  #
+  my $have_data_for_the_table = 0;
+  while (my ($o, $v) = each(%{$record_hashref})) {
+    if (Golem::is_data_field($table_name, $o)) {
+      my $is_unique = 0;
+
+      foreach my $u (@{$unique_fields_arrayref}) {
+        if ($u eq $o) {
+          $is_unique = 1;
+        }
+      }
+      next if $is_unique;
+
+      $have_data_for_the_table = 1;
+    }
+  }
+  unless ($have_data_for_the_table || $opts->{'create_empty_record'}) {
+    return $dbh;
+  }
+
+  my $sql;
+  my @bound_values;
+
+  $sql = "SELECT " . $table->{'select_all_sql'} . " from `$table_name` WHERE ";
+  foreach my $f (@{$unique_fields_arrayref}) {
+    if ($table_fields->{$f}->{'Type'} eq 'timestamp' && $record_hashref->{$f} != 0) {
+      Golem::die("Programmer error: __update got hashref with invalid data for $table_name.$f (should be unixtime)")
+        unless $record_hashref->{$f} =~ /^[0-9]+$/o;
+
+      $sql .= " `$f` = FROM_UNIXTIME(?) and ";
+    }
+    else {
+      $sql .= " `$f` = ? and ";
+    }
+    push @bound_values, $record_hashref->{$f};
+  }
+  # remove last "and "
+  chop($sql);
+  chop($sql);
+  chop($sql);
+  chop($sql);
+
+  $sth = $dbh->prepare($sql);
+  Golem::sth_bind_array($sth, \@bound_values);
+  $sth->execute();
+
+  # create record if it doesn't exist: useful when updating
+  # records in dependent tables (hosts_resps, hosts_netmap, host_rackmap)
+  # when master table exists.
+  unless ($sth->rows) {
+    if ($opts->{"create_nonexistent"}) {
+      $dbh = Golem::__insert($table_name, $record_hashref, $opts);
+      return $dbh;
+    }
+    else {
+      Golem::die("Programmer error: requested to update non-existent record with no create_nonexistent option");
+    }
+  }
+
+  my $existing_row;
+  while(my $r = $sth->fetchrow_hashref()) {
+    Golem::debug_sql($sql, \@bound_values);
+    Golem::die("more than 1 record fetched with should-be-unique lookup")
+      if $existing_row;
+
+    $existing_row = $r;
+  }
+  
+  # check that existing record differs somehow from record to be written
+  my $records_differ = 0;
+  while (my ($k, $v) = each %{$existing_row}) {
+    if (Golem::is_data_field($table_name, $k)) {
+      
+      # what a mess!
+      utf8::decode($record_hashref->{$k});
+      utf8::decode($v);
+      
+      if (
+          ($record_hashref->{$k} && $v && $v ne $record_hashref->{$k}) ||
+          (! $record_hashref->{$k} && $v) ||
+          ($record_hashref->{$k} && ! $v)
+        ) {
+
+        Golem::debug_sql("in-memory [$table_name] object field [$k] differs: [" .
+          ($record_hashref->{$k} ? $record_hashref->{$k} : "") . "
+          ] -- [" .
+          ($v ? $v : "") .
+          "]");
+
+        $records_differ = 1;
+        last;
+      }
+    }
+  }
+
+  # don't update database if that wouldn't actually
+  # change any data; we should save A LOT of time here
+  #
+  return $dbh unless $records_differ;
+
+  @bound_values = ();
+  $sql = "";
+  while (my ($o, $v) = each(%{$record_hashref})) {
+    # $record_hashref might contain more fields than present in database.
+    # we only choose those which are in db
+    if ($table_fields->{$o} && Golem::is_data_field($table_name, $o)) {
+      if ($table_fields->{$o}->{'Type'} eq 'timestamp' && $record_hashref->{$o} && $record_hashref->{$o} != 0) {
+        Golem::die("Programmer error: __update got hashref with invalid data for $table_name.$o (should be unixtime)")
+          unless $record_hashref->{$o} =~ /^[0-9]+$/o;
+
+        $sql = $sql . " `$o` = FROM_UNIXTIME(?),";
+      }
+      else {
+        $sql = $sql . " `$o` = ?,";
+      }
+      push @bound_values, $record_hashref->{$o};
+    }
+  }
+  chop($sql);
+
+  $sql = "UPDATE `$table_name` SET " . $sql . " WHERE ";
+  foreach my $f (@{$unique_fields_arrayref}) {
+    $sql .= " `$f` = ? and ";
+    push @bound_values, $record_hashref->{$f};
+  }
+  # remove last "and "
+  chop($sql);
+  chop($sql);
+  chop($sql);
+  chop($sql);
+
+  Golem::debug_sql($sql, \@bound_values);
+
+  $sth = $dbh->prepare($sql);
+  Golem::sth_bind_array($sth, \@bound_values);
+  $sth->execute();
+
+  if ($dbh->err) {
+    Golem::do_log("error executing: $sql; bound values: " . join(",", @bound_values), {"stderr" => 1});
+  }
+
+  return $dbh;
+}
+
+
+sub __delete {
+  my ($table_name, $record_hashref, $opts) = @_;
+
+  Golem::die("Severe programmer error: __delete expects table name as first parameter!")
+    unless $table_name;
+  Golem::die("Severe programmer error: __delete expects record hashref as second parameter!")
+    unless ref($record_hashref) eq 'HASH';
+  
+  $opts = {} unless ref($opts) eq 'HASH';
+
+  my $dbh;
+  if ($opts->{'dbh'}) {
+    $dbh = $opts->{'dbh'};
+  }
+  else {
+    $dbh = Golem::get_db();
+  }
+
+  my $sth;
+  
+  my $table = Golem::get_schema_table($table_name);
+  my $table_fields = $table->{'fields'};
+  my $unique_fields_arrayref = [keys %{$table->{'primary_key'}}];
+
+  if ($opts->{'unique_fields'}) {
+    $unique_fields_arrayref = $opts->{'unique_fields'};
+  }
+
+  my @bound_values = ();
+  my $sql = "DELETE FROM `$table_name` WHERE ";
+
+  foreach my $f (@{$unique_fields_arrayref}) {
+    $sql .= " `$f` = ? and ";
+    push @bound_values, $record_hashref->{$f};
+  }
+  # remove last "and "
+  chop($sql);
+  chop($sql);
+  chop($sql);
+  chop($sql);
+
+  $sth = $dbh->prepare($sql);
+  Golem::sth_bind_array($sth, \@bound_values);
+  $sth->execute();
+
+  if ($dbh->err) {
+    Golem::do_log("error executing: $sql; bound values: " . join(",", @bound_values), {"stderr" => 1});
+  }
+
+  return $dbh;
+}
+
+
+1;

local/cgi-bin/Golem/loglib.pl

@@ -0,0 +1,197 @@
+#!/usr/bin/perl -w
+#
+# Logging related routines
+#
+
+
+package Golem;
+use strict;
+
+use Golem;
+use Data::Dumper;
+
+
+sub dumper {
+  my ($v) = @_;
+
+  return Dumper($v);
+}
+
+sub debug_sql {
+  my ($text, $bound_values, $opts) = @_;
+
+  if ($Golem::debug_sql) {
+    $opts = {} unless $opts;
+
+    $text = "SQL: [" . ($text ? $text : "") . "]";
+    
+    if ($bound_values && ref($bound_values) eq 'ARRAY') {
+      $text .= " bound_values [" . Golem::safe_join(",", @{$bound_values}) . "]";
+    }
+
+    if ($opts->{'stderr'}) {
+      print STDERR localtime() . " " . $text . "\n";
+    }
+    else {
+      print localtime() . " " . $text . "\n";
+    }
+  }
+}
+
+sub debug2 {
+  my ($text, $opts) = @_;
+  
+  if ($Golem::debug2) {
+    debug($text, $opts);
+  }
+}
+
+sub debug {
+  my ($text, $opts) = @_;
+
+  $opts = {} unless $opts;
+
+  if ($Golem::debug) {
+    my $stamp = localtime() . ": ";
+
+    utf8::encode($text) if utf8::is_utf8($text);
+    
+    if ($opts->{'stderr'}) {
+      if (ref($text)) {
+        print STDERR join("", map { "$stamp$_\n" } Dumper($text));
+      }
+      else {
+        print STDERR $stamp . ($text ? $text : "") . "\n";
+      }
+    }
+    else {
+      if (ref($text)) {
+        print join("", map { "$stamp$_\n" } Dumper($text));
+      }
+      else {
+        print $stamp . ($text ? $text : "") . "\n";
+      }
+    }
+  }
+}
+
+# safe_open and safe_close are copied
+# from ps_farm.pm (should be one library actually)
+sub safe_open {
+  my ($filename, $mode, $timeout) = @_;
+
+  $timeout = 30 unless $timeout;
+  $mode = "open" unless $mode;
+
+  if ($mode eq "overwrite" || $mode eq ">") {
+    $mode = ">";
+  }
+  elsif ($mode eq "append" || $mode eq ">>") {
+    $mode = ">>";
+  }
+  else {
+    $mode = "";
+  }
+
+  my $fh;
+  my $i=0;
+  while (! open($fh, "${mode}${filename}")) {
+    if ($i > $timeout) {
+      print STDERR "Unable to open $filename\n";
+      return 0;
+    }
+
+    print STDERR "still trying to open $filename\n";
+    $i = $i + 1;
+    sleep 1;
+  }
+
+  while (! flock($fh, 2)) {
+    if ($i > $timeout) {
+      print STDERR "Unable to lock $filename\n";
+      return 0;
+    }
+
+    print STDERR "still trying to lock $filename\n";
+    $i = $i + 1;
+    sleep 1;
+  }
+
+  my $fh1;
+  if (!open($fh1, "${mode}${filename}")) {
+    $i = $i + 1;
+
+    if ($i > $timeout) {
+      print STDERR "Unable to open and lock $filename\n";
+      return 0;
+    }
+
+    print STDERR "Locked $filename, but it's gone. Retrying...\n";
+    return safe_open($filename, $mode, $timeout - 1);
+  }
+  else {
+    close($fh1);
+    return $fh;
+  }
+}
+
+sub safe_close {
+  my ($fh) = @_;
+  return flock($fh, 8) && close($fh);
+}
+
+sub do_log {
+    my ($message, $opts) = @_;
+    
+    my $module;
+    my $stderr = 0;
+    
+    if (ref($opts) eq 'HASH') {
+      if ($opts->{'module'}) {
+        $module = "[$opts->{'module'}] ";
+      }
+      if ($opts->{'stderr'}) {
+        $stderr = $opts->{'stderr'};
+      }
+    }
+    else {
+      $module = $opts;
+      $module = "[$module] " if $module;
+    }
+    
+    $message = "" unless $message;
+
+    utf8::encode($message) if utf8::is_utf8($message);
+    
+    $module = "[" . $0 . "] " unless $module;
+
+    my $message_eol = chop($message);
+    
+    my $message_formatted =
+      localtime() . " " . $module .
+      $message .
+      $message_eol .
+      ($message_eol eq "\n" ? "" : "\n");
+    
+    if ($stderr) {
+      print STDERR $message_formatted;
+    }
+    elsif ($Golem::debug) {
+      print $message_formatted;
+    }
+    
+    if (defined($Golem::LOG)) {
+	    my $fh = safe_open($Golem::LOG, ">>");
+	    Golem::die ("Unable to open $Golem::LOG\n") unless $fh;
+#    binmode($fh, ":utf8");
+	    print $fh $message_formatted;
+  	  safe_close($fh);
+  	}
+  	else {
+  		print STDERR "No Golem::LOG is configured. Logging to STDERR\n";
+  		print STDERR $message_formatted;
+  	}
+}
+
+
+1;

local/cgi-bin/Golem/netlib.pl

@@ -0,0 +1,330 @@
+#!/usr/bin/perl -w
+#
+# networking related routines
+#
+
+
+package Golem;
+use strict;
+
+use Golem;
+
+sub get_external_ipinfo {
+  my ($ip) = @_;
+
+  return undef unless $ip && $Golem::noc_nets_cgi;
+
+  my $ipinfo;
+  my @net_info;
+
+  my $wget_options = "";
+  $wget_options = "--timeout=${Golem::noc_nets_cgi_timeout}"
+    if $Golem::noc_nets_cgi_timeout;
+
+  open(NOCNET,"wget $wget_options -q -O - ${Golem::noc_nets_cgi}?name=$ip |");
+
+  Golem::debug("wget $wget_options -q -O - ${Golem::noc_nets_cgi}?name=$ip |");
+
+  my $line;
+  while($line=<NOCNET>) {
+    if ($line=~/^<tr align=center>/) {
+      chomp($line);
+      $line =~ s/<\/td><td>/\|/g;
+      $line =~ s/(<td>|<tr align=center>|<\/tr>|<\/td>)//g;
+      @net_info= split(/\|/,$line,5);
+    }
+  }
+  close(NOCNET);
+
+  if (@net_info) {
+    $ipinfo->{'ip'} = $net_info[0];
+    $ipinfo->{'subnet'} = $net_info[1];
+    $ipinfo->{'router'} = $net_info[2];
+    $ipinfo->{'iface'} = $net_info[3];
+
+    $ipinfo->{'vlan'} = $ipinfo->{'iface'};
+    $ipinfo->{'vlan'} =~ /(\d+)/;
+    $ipinfo->{'vlan'} = $1;
+
+    $ipinfo->{'router_if_addr'} = $net_info[4];
+  }
+
+  return $ipinfo;
+}
+
+# --- ghetto code
+sub int2maskpart {
+  my ($i) = @_;
+  return "0" unless defined($i);
+
+  my $j = 0;
+  my $bits = "";
+  while ($j < 8) {
+    if ($i <= $j) {
+      $bits .= "0";
+    }
+    else {
+      $bits .= "1";
+    }
+    $j++;
+  }
+  return oct("0b" . $bits);
+}
+
+
+sub mask2netmask {
+  my ($j) = @_;
+
+  my @ip;
+  my $i;
+  for ($i = 1; $i <= int($j / 8); $i++) {
+    push @ip, int2maskpart(8);
+  }
+  while ($i < 5) {
+    push @ip, int2maskpart($j % 8);
+    $j = 0;
+    $i++;
+  }
+
+  return join(".", @ip);
+}
+
+
+# convert string representation of ipv4 address into integer
+sub ipv4_str2int {
+  my ($ip_string) = @_;
+
+  if ($ip_string =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
+    return (16777216 * $1) + (65536 * $2) + (256 * $3) + $4;
+  }
+  else {
+    return 0;
+  }
+}
+
+# convert integer representation of ipv4 address into string
+sub ipv4_int2str {
+  my ($ip_int) = @_;
+
+  if ($ip_int >= 0  && $ip_int <= 4294967295) {
+    my $w = ($ip_int / 16777216) % 256;
+    my $x = ($ip_int / 65536) % 256;
+    my $y = ($ip_int / 256) % 256;
+    my $z = $ip_int % 256;
+
+    return $w . "." . $x . "." . $y . "." . $z;
+  }
+  else {
+    return 0;
+  }
+}
+
+# /24 -> +255
+# /27 -> +31
+# /28 -> +15
+# /29 -> +7
+sub ipv4_mask2offset {
+  my ($mask) = @_;
+  $mask ||= 0;
+  my $offset = 2 ** (32 - $mask);
+  return $offset - 1;
+}
+
+sub get_net {
+  my ($ip, $mask, $opts) = @_;
+
+  Golem::trim(\$ip);
+  
+  Golem::die("Programmer error: get_net expects net and mask")
+    unless
+    	($ip && $mask && Golem::is_digital($mask)) ||
+    	($ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\/\d{1,2}$/);
+
+  if ($ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\/(\d{1,2})$/o) {
+    $ip = ipv4_str2int($1);
+    $mask = $2;
+  }
+  elsif ($ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/o) {
+    $ip = ipv4_str2int($1);
+  }
+
+  my $dbh = Golem::get_db();
+  my $sth = $dbh->prepare("SELECT * FROM net_v4 WHERE ip = ? and mask = ?");
+  $sth->execute($ip, $mask);
+  my $net = $sth->fetchrow_hashref();
+  $sth->finish();
+
+  if ($net->{'id'}) {
+    return Golem::get_net_by_id($net->{'id'}, $opts);
+  }
+  else {
+    return 0;
+  }
+}
+
+sub get_net_by_id {
+	my ($id, $opts) = @_;
+
+	Golem::die("Programmer error: get_net_by_id expects network id")
+		unless $id;
+
+	$opts = {} unless $opts;
+
+  my $dbh = Golem::get_db();
+  my $sth = $dbh->prepare("SELECT * FROM net_v4 WHERE id = ?");
+	
+  $sth->execute($id);
+
+	my $r = $sth->fetchrow_hashref();
+	if ($r->{'id'}) {
+    $r->{'ip_str'} = Golem::ipv4_int2str($r->{'ip'});
+    $r->{'net_with_mask'} = $r->{'ip_str'} . "/" . $r->{'mask'};
+    if ($r->{'name'} =~ /VLAN([\d]+)/o) {
+      $r->{'vlan'} = $1;
+    }
+    else {
+      $r->{'vlan'} = "";
+    }
+
+	  if ($opts->{'with_props'} || $opts->{'with_all'}) {
+  	  $r = Golem::load_props("net_v4", $r);
+  	}
+
+    return $r;
+	}
+	else {
+	  return 0;
+	}
+}
+
+sub insert_net {
+  my ($net) = @_;
+
+  Golem::die("Programmer error: insert_net expects net object")
+    unless $net && ($net->{'ip_str'} || $net->{'ip'}) &&
+      $net->{'mask'} && $net->{'name'};
+  
+  if ($net->{'ip_str'}) {
+    $net->{'ip'} = Golem::ipv4_str2int($net->{'ip_str'});
+  }
+
+  my $enet = Golem::get_net($net->{'ip'}, $net->{'mask'});
+  return Golem::err("net already exists [$enet->{'ip_str'}/$enet->{'$mask'} ($enet->{'id'})]")
+    if $enet;
+
+  my $dbh = Golem::__insert("net_v4", $net);
+  return Golem::err($dbh->errstr, $net)
+    if $dbh->err;
+
+  $net->{'id'} = $dbh->selectrow_array("SELECT LAST_INSERT_ID()");
+
+  return Golem::get_net_by_id($net->{'id'});
+}
+
+sub save_net {
+  my ($net) = @_;
+
+  Golem::die("Programmer error: save_net expects net object")
+    unless $net && $net->{'id'} &&
+      ($net->{'ip_str'} || $net->{'ip'}) &&
+      $net->{'mask'} && $net->{'name'};
+  
+  if ($net->{'ip_str'}) {
+    $net->{'ip'} = Golem::ipv4_str2int($net->{'ip_str'});
+  }
+
+  my $enet = Golem::get_net($net->{'ip'}, $net->{'mask'}, {"with_all" => 1});
+
+  if ($enet) {
+    my $dbh = Golem::__update("net_v4", $net);
+    return Golem::err($dbh->errstr, $net)
+      if $dbh->err;
+
+		$net = Golem::save_props("net_v4", $net);
+  }
+  else {
+    return Golem::insert_net($net);
+  }
+
+  return $net;
+}
+
+sub delete_net {
+  my ($net) = @_;
+
+  Golem::die("Programmer error: delete_net expects net object")
+    unless $net && $net->{'id'};
+  
+  my $dbh = Golem::get_db();
+
+  Golem::unset_row_tag("net_v4", $net->{'id'});
+  $dbh->do("DELETE from net_v4prop where net_v4id = ?", undef, $net->{'id'});
+  $dbh->do("DELETE from net_v4propblob where net_v4id = ?", undef, $net->{'id'});
+  
+  $dbh->do("DELETE FROM net_v4 WHERE net_v4.id = ?", undef, $net->{'id'});
+  return Golem::err($dbh->errstr, $net)
+    if $dbh->err;
+
+  return {};
+}
+
+sub get_containing_net {
+  my ($ip, $opts) = @_;
+
+  Golem::die("Programmer error: get_containing_net expects ip address")
+    unless $ip;
+
+  Golem::trim(\$ip);
+  if ($ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/o) {
+    $ip = Golem::ipv4_str2int($1);
+  }
+  
+  my $dbh = Golem::get_db();
+  
+  # choose nearest (by ip desc) and smallest (by mask desc) known network
+  my $sth = $dbh->prepare("SELECT * FROM net_v4 WHERE ip < ? and mask <> 32
+    order by ip desc, mask desc");
+
+  $sth->execute($ip);
+
+  my $net;
+
+  while(my $r = $sth->fetchrow_hashref()) {
+    # choose first network that includes tested ip address if any
+    if ($r->{'ip'} + ipv4_mask2offset($r->{'mask'}) ge $ip) {
+      return Golem::get_net_by_id($r->{'id'}, $opts);
+    }
+  }
+
+  return 0;
+}
+
+sub get_net_by_vlan {
+  my ($vlan, $opts) = @_;
+
+  Golem::die("Programmer error: get_net_by_vlan expects vlan name")
+    unless $vlan;
+
+  $vlan =~ s/vlan//go;
+  $vlan =~ s/\s//go;
+
+  my $dbh = Golem::get_db();
+  my $sth = $dbh->prepare("SELECT * FROM net_v4 WHERE mask <> 32 and name like ? order by name");
+  $sth->execute("VLAN${vlan}%");
+
+  while (my $r = $sth->fetchrow_hashref()) {
+    if ($r->{'name'} =~ /VLAN${vlan}\s/o) {
+      return Golem::get_net($r->{'ip'}, $r->{'mask'}, $opts);
+    }
+  }
+
+  return 0;
+}
+
+sub is_ipv4 {
+  my ($str) = @_;
+  return $str =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/o;
+}
+
+
+1;

local/cgi-bin/Golem/proplib.pl

@@ -0,0 +1,393 @@
+#!/usr/bin/perl -w
+#
+# Properties manipulation routines
+#
+#
+# This is an object property library which
+# implements DB -> MEMORY (load_props)
+# and MEMORY -> DB (save_props) transition
+# of object properties
+#
+# Object is defined as a record in some TABLE
+# (called owner). To be able to use properties
+# for the given TABLE you should create
+# another two tables: TABLEprop and TABLEpropblob
+#
+# Example for host object:
+#
+#   CREATE TABLE `hostprop` (
+#     `hostid` int(11) NOT NULL,
+#     `propid` smallint(6) NOT NULL default '0',
+#     `propseq` int(11) NOT NULL default '0',
+#     `value` varchar(1024) default NULL,
+#     PRIMARY KEY  (`hostid`,`propid`,`propseq`),
+#     KEY `prop` (`propid`)
+#   ) ENGINE=InnoDB DEFAULT CHARSET=utf8
+#
+#   CREATE TABLE `hostpropblob` (
+#     `hostid` int(11) NOT NULL,
+#     `propid` smallint(6) NOT NULL default '0',
+#     `propseq` int(11) NOT NULL default '0',
+#     `value` blob,
+#     PRIMARY KEY  (`hostid`,`propid`,`propseq`),
+#     KEY `prop` (`propid`)
+#   ) ENGINE=InnoDB DEFAULT CHARSET=utf8
+#
+# After that you should create "allowed" properties
+# for the owner using `gconsole.pl --create-proplist`
+#
+# You could see all the defined properties for the owner
+# using gconsole.pl --list-proplist OWNER
+#
+#
+# For the owner (tables) which primary key is not simple
+# id auto_increment (as in the example above) the following
+# TABLEprop and TABLEpropblob structure should be used:
+#
+
+package Golem;
+use strict;
+
+use Golem;
+
+use Storable;
+
+
+# check that given property owner is valid
+# currently there are two valid property owners: host, user
+# 
+sub check_prop_owner {
+  my ($owner) = @_;
+
+  Golem::die("Programmer error: check_prop_owner got empty prop owner")
+    unless $owner;
+
+  my $props = {
+    "eventhistory" => 1,
+    "host" => 1,
+    "user" => 1,
+    "net_v4" => 1,
+    };
+
+  Golem::die("Programmer error: not valid property owner [$owner]")
+    unless defined($props->{$owner});
+}
+
+# get property definition record(s) from database
+# for the specified owner
+#
+sub get_proplist {
+  my ($owner, $hpname) = @_;
+
+  Golem::die("Programmer error: get_proplist expects at least owner")
+    unless $owner;
+
+  Golem::check_prop_owner($owner);
+
+  my $dbh = Golem::get_db();
+  my $sth;
+  my $ret;
+
+  if ($hpname) {
+    $sth = $dbh->prepare("SELECT * FROM proplist WHERE owner = ? and name = ?");
+    $sth->execute($owner, $hpname);
+    $ret = $sth->fetchrow_hashref();
+    $ret = 0 unless $ret->{'id'};
+  }
+  else {
+    $sth = $dbh->prepare("SELECT * FROM proplist where owner = ?");
+    $sth->execute($owner);
+    while (my $r = $sth->fetchrow_hashref()) {
+      $ret->{$r->{'name'}} = $r;
+    }
+  }
+
+  return $ret;
+}
+
+sub create_proplist {
+  my ($owner, $op) = @_;
+
+  Golem::die("Programmer error: create_proplist expects at least owner and property name")
+    unless $owner && $op && $op->{'name'};
+
+  Golem::check_prop_owner($owner);
+    
+  my $eop = Golem::get_proplist($owner, $op->{'name'});
+  Golem::die("proplist record already exists [$eop->{'name'} ($eop->{'id'})]")
+    if $eop;
+
+  $op->{'owner'} = $owner;
+
+  my $dbh = Golem::__insert("proplist", $op);
+  Golem::die("Error creating proplist: " . $dbh->errstr, $op)
+    if $dbh->err;
+
+  $op->{'id'} = $dbh->selectrow_array("SELECT LAST_INSERT_ID()");
+  
+  Golem::do_log("new proplist record: [$op->{'owner'}/$op->{'name'}] ($op->{'id'})");
+  
+  return $op;
+}
+
+sub delete_proplist {
+  my ($owner, $op) = @_;
+
+  Golem::die("Programmer error: delete_proplist expects proplist record")
+    unless $op && $op->{'id'} && $op->{'name'};
+
+  Golem::check_prop_owner($owner);
+
+  my $eop = Golem::get_proplist($owner, $op->{'name'});
+  
+  return Golem::err("delete_proplist: invalid proplist record")
+    unless $eop;
+
+  my $dbh = Golem::get_db();
+  my $objs_with_prop =
+    $dbh->selectrow_array("select count(*) from ${owner}prop where propid = ?", undef, $op->{'id'}) +
+    $dbh->selectrow_array("select count(*) from ${owner}propblob where propid = ?", undef, $op->{'id'})
+    ;
+
+  return Golem::err("delete_proplist: unable to delete proplist record; $objs_with_prop records are using it")
+    if $objs_with_prop;
+
+  $dbh->do("delete from proplist where id = ?", undef, $op->{'id'});
+
+  return Golem::err("error while deleting from proplist: " . $dbh->errstr)
+    if $dbh->err;
+
+  return {};
+}
+
+# read object properties for the given owner
+# (exactly matches table name)
+#
+sub load_props {
+  my ($owner, $o) = @_;
+
+  Golem::die("Programmer error: load_props expects owner name and object")
+    unless $owner && ref($o);
+
+  Golem::check_prop_owner($owner);
+
+  my $table = Golem::get_schema_table($owner);
+  my $pk = $table->{'primary_key'};
+
+  my $dbh = Golem::get_db();
+  my $sth;
+  
+  $o->{'props'}->{'data'} = {};
+
+  foreach my $t ("${owner}prop", "${owner}propblob") {
+    my $sql = "select * from $t inner join proplist on proplist.id = $t.propid WHERE 1 ";
+    my @bound_values = ();
+    while (my ($pk_field, $dummy) = each %{$table->{'primary_key'}}) {
+      if ($pk_field eq 'id') {
+        $sql .= " and `${owner}id` = ? ";
+      }
+      else {
+        $sql .= " and `$pk_field` = ? ";
+      }
+
+      Golem::die("Programmer error: load_props got empty value for primary key field [$pk_field] of table [$owner]")
+        unless defined($o->{$pk_field});
+
+      push (@bound_values, $o->{$pk_field});
+    }
+    $sth = $dbh->prepare($sql);
+    Golem::sth_bind_array($sth, \@bound_values);
+    $sth->execute();
+
+    while (my $r = $sth->fetchrow_hashref()) {
+      my $v;
+
+      if ($t eq "${owner}prop") {
+        $v = $r->{'value'};
+      }
+      if ($t eq "${owner}propblob") {
+#        print STDERR Storable::thaw($r->{'value'});
+        $v = Storable::thaw($r->{'value'});
+      }
+    
+      if ($r->{'datatype'} eq 'array' || $r->{'datatype'} eq 'arrayblob') {
+        $o->{'props'}->{'data'}->{$r->{'name'}} = []
+          unless defined($o->{'props'}->{'data'}->{$r->{'name'}});
+
+        push (@{$o->{'props'}->{'data'}->{$r->{'name'}}}, $v);
+      }
+      else {
+        $o->{'props'}->{'data'}->{$r->{'name'}} = $v;
+      }
+    }
+  }
+
+  $o->{'props'}->{'loaded'} = 1;
+
+  return $o;
+}
+
+# save properties from memory into database
+# checks that properties were loaded using load_props
+# (for advanced users: "loaded" is the key of check,
+# it is set by load_props which could be emulated)
+#
+sub save_props {
+  my ($owner, $o) = @_;
+
+  Golem::die("Programmer error: save_props expects owner name and object")
+    unless $owner && ref($o);
+
+  Golem::check_prop_owner($owner);
+
+  return Golem::err("Programmer error: save_props should be called only after calling load_props")
+    unless $o->{'props'}->{'loaded'};
+
+  my $table = Golem::get_schema_table($owner);
+  my $pk = $table->{'primary_key'};
+
+  my $dbh = Golem::get_db();
+
+  while (my ($k, $v) = each %{$o->{'props'}->{'data'}}) {
+    my $op = Golem::get_proplist($owner, $k);
+    
+    unless ($op) {
+      Golem::do_log("Non-existent $owner property name [$k], skipping.", {"stderr" => 1});
+      next;
+    }
+
+    my $do_save = sub {
+      my ($value, $seq) = @_;
+
+      $seq = 0 unless defined($seq);
+      
+      my $tpref = "";
+      my $db_value;
+
+      if ($op->{'datatype'} eq 'blob' || $op->{'datatype'} eq 'arrayblob') {
+        $db_value = Storable::nfreeze($value);
+        $tpref = "blob";
+      }
+      else {
+        $db_value = $value;
+
+        if ($op->{'datatype'} eq 'bool') {
+          $db_value = $value ? 1 : 0;
+        }
+      }
+
+      my $prop_ref =  {
+        "propid" => $op->{'id'},
+        "propseq" => $seq,
+        "value" => $db_value,
+        };
+      
+      while (my ($pk_field, $dummy) = each %{$table->{'primary_key'}}) {
+        if ($pk_field eq 'id') {
+          $prop_ref->{"${owner}id"} = $o->{$pk_field};
+        }
+        else {
+          $prop_ref->{$pk_field} = $o->{$pk_field};
+        }
+      }
+
+      $dbh = Golem::__update("${owner}prop${tpref}", $prop_ref, {"create_nonexistent" => 1});
+      Golem::die("save_props: error while replacing ${owner} props: " . $dbh->errstr)
+        if $dbh->err;
+    };
+
+    if ($op->{'datatype'} eq 'array' || $op->{'datatype'} eq 'arrayblob') {
+      my $i = 0;
+      foreach my $array_value (@{$v}) {
+        $do_save->($array_value, $i);
+        $i = $i + 1;
+      }
+      
+      my $tpref = "";
+      if ($op->{'datatype'} eq 'arrayblob') {
+        $tpref = "blob";
+      }
+
+      my $sql = "delete from ${owner}prop${tpref} where 1 ";
+      my @bound_values = ();
+      while (my ($pk_field, $dummy) = each %{$table->{'primary_key'}}) {
+        if ($pk_field eq 'id') {
+          $sql .= " and ${owner}id = ? ";
+        }
+        else {
+          $sql .= " and $pk_field = ? ";
+        }
+        push (@bound_values, $o->{$pk_field});
+      }
+      $sql .= " and propid = ? and propseq >= ?";
+      push (@bound_values, $op->{'id'});
+      push (@bound_values, $i);
+
+      my $sth = $dbh->prepare($sql);
+      Golem::sth_bind_array($sth, \@bound_values);
+      $sth->execute();
+    }
+    else {
+      $do_save->($v, 0);
+    }
+  }
+
+  return $o;
+}
+
+# deletes object property if no objects
+# are associated with the property
+#
+# input
+#   owner type (for the listing see check_prop_owner)
+#   object (with $obj->{'id'} defined)
+#   property name to delete
+#
+sub delete_prop {
+  my ($owner, $obj, $propname) = @_;
+
+  Golem::die("Programmer error: delete_prop expects owner and object")
+    unless $owner && ref($obj);
+
+  Golem::check_prop_owner($owner);
+
+  my $op = Golem::get_proplist($owner, $propname);
+  return Golem::err("delete_prop: invalid propname [$propname]")
+    unless $op;
+
+  my $table = Golem::get_schema_table($owner);
+  my $pk = $table->{'primary_key'};
+
+  my $dbh = Golem::get_db();
+  
+  my $tpref = "";
+  if ($op->{'datatype'} eq 'blob' || $op->{'datatype'} eq 'blobarray') {
+    $tpref = "blob";
+  }
+  
+  my $sql = "delete from ${owner}prop${tpref} where 1 ";
+  my @bound_values = ();
+  while (my ($pk_field, $dummy) = each %{$table->{'primary_key'}}) {
+    if ($pk_field eq 'id') {
+      $sql .= " and ${owner}id = ? ";
+    }
+    else {
+      $sql .= " and $pk_field = ? ";
+    }
+    push (@bound_values, $obj->{$pk_field});
+  }
+  $sql .= " and propid = ? ";
+  push (@bound_values, $op->{'id'});
+
+  my $sth = $dbh->prepare($sql);
+  Golem::sth_bind_array($sth, \@bound_values);
+  $sth->execute();
+
+  Golem::die("delete_prop: error deleting $owner [$obj->{'id'}] property [$propname]: " . $dbh->errstr)
+    if $dbh->err;
+
+  return {};
+}
+
+
+1;

local/cgi-bin/Golem/textlib.pl

@@ -0,0 +1,222 @@
+#!/usr/bin/perl -w
+#
+# Text manipulation routines
+#
+#   parts courtesy of LiveJournal.org
+#
+
+package Golem;
+use strict;
+
+use Golem;
+
+# <LJFUNC>
+# name: LJ::decode_url_string
+# class: web
+# des: Parse URL-style arg/value pairs into a hash.
+# args: buffer, hashref
+# des-buffer: Scalar or scalarref of buffer to parse.
+# des-hashref: Hashref to populate.
+# returns: boolean; true.
+# </LJFUNC>
+sub decode_url_string
+{
+    my $a = shift;
+    my $buffer = ref $a ? $a : \$a;
+    my $hashref = shift;  # output hash
+    my $keyref  = shift;  # array of keys as they were found
+
+    my $pair;
+    my @pairs = split(/&/, $$buffer);
+    @$keyref = @pairs;
+    my ($name, $value);
+    foreach $pair (@pairs)
+    {
+        ($name, $value) = split(/=/, $pair);
+        $value =~ tr/+/ /;
+        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $name =~ tr/+/ /;
+        $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $hashref->{$name} .= $hashref->{$name} ? ",$value" : $value;
+    }
+    return 1;
+}
+
+
+# <LJFUNC>
+# name: LJ::ehtml
+# class: text
+# des: Escapes a value before it can be put in HTML.
+# args: string
+# des-string: string to be escaped
+# returns: string escaped.
+# </LJFUNC>
+sub ehtml
+{
+    # fast path for the commmon case:
+    return $_[0] unless $_[0] =~ /[&\"\'<>]/o;
+
+    # this is faster than doing one substitution with a map:
+    my $a = $_[0];
+    $a =~ s/\&/&amp;/g;
+    $a =~ s/\"/&quot;/g;
+    $a =~ s/\'/&\#39;/g;
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    return $a;
+}
+
+sub esql {
+  return $_[0] unless $_[0] =~ /[\'\"\\]/o;
+
+  my $a = $_[0];
+  $a =~ s/\'//go;
+  $a =~ s/\"//go;
+  $a =~ s/\\//go;
+  return $a;
+}
+
+# <LJFUNC>
+# name: LJ::is_ascii
+# des: checks if text is pure ASCII.
+# args: text
+# des-text: text to check for being pure 7-bit ASCII text.
+# returns: 1 if text is indeed pure 7-bit, 0 otherwise.
+# </LJFUNC>
+sub is_ascii {
+    my $text = shift;
+    return ($text !~ m/[^\x01-\x7f]/o);
+}
+
+sub is_digital {
+  my $text = shift;
+  return ( $text =~ /\d+/o );
+}
+
+# tests if there's data in configuration file string:
+# i.e. if it's not empty and is not commented
+#
+sub have_data {
+  my ($line) = @_;
+
+  if ($line =~ /^\s*#/o || $line =~ /^[\s]*$/o) {
+    return 0;
+  }
+
+  return 1;
+}
+
+# fixes user input strings (passed as array of references),
+# currently only trims
+#
+# used when importing:
+#   - 1C data
+#
+sub fix_input {
+  my (@i) = @_;
+  
+  foreach my $v (@i) {
+    Golem::die("Programmer error: check_input expects only scalar references")
+      unless ref($v) eq 'SCALAR';
+
+    Golem::do_log("Inaccurate spacing trimmed [$$v]", {"stderr" => 1})
+      if Golem::trim($v);
+  }
+}
+
+# given scalar string trims white space
+# at the beginning and in the end and
+# returns trimmed string
+#
+# given scalar reference trims white space
+# at the beginning and in the end and
+# returns true if trimming occured and false otherwise
+# NOTE: modifies the original string
+# reference to which was given as input parameter
+sub trim {
+  my ($string) = @_;
+  
+  if (ref($string) eq 'SCALAR') {
+    my $tstr = $$string;
+    
+    return 0 if $tstr eq ''; # nothing to trim, do not waste cpu cycles
+    
+    $tstr =~ s/^\s+//so;
+    $tstr =~ s/\s+$//so;
+    
+    if ($tstr ne $$string) {
+      $$string = $tstr;
+      return 1;
+    }
+    else {
+      return 0;
+    }
+  }
+  else {
+    return "" if $string eq ''; # nothing to trim, do not waste cpu cycles
+
+    $string =~ s/^\s+//so;
+    $string =~ s/\s+$//so;
+    return $string;
+  }
+}
+
+# same as standard perl join except for it doesn't
+# output "uninitialized value in join" when joining
+# list with undef values; and we use those lists
+# when binding params to DBI query
+#
+sub safe_join {
+  my ($delimiter, @arr) = @_;
+
+  my $joined_text = "";
+  $delimiter = "" unless $delimiter;
+
+  foreach my $bv (@arr) {
+    $joined_text .= ($bv ? $bv : "") . $delimiter;
+  }
+  
+  my $i;
+  for ($i = 0; $i < length($delimiter); $i++) {
+    chop($joined_text);
+  }
+
+  return $joined_text;
+}
+
+# should be used when you need to concatenate string
+# which might be undefined and you want empty string ("")
+# instead of perl warnings about uninitialized values
+#
+sub safe_string {
+  my ($str) = @_;
+
+  if ($str) {
+    return $str;
+  }
+  else {
+    return "";
+  }
+}
+
+# inserts $symbol every $range characters in a $line
+sub div_line {
+  my ($line, $range, $symbol) = @_;
+  
+  Golem::die("Programmer error: div_line expects at least string")
+    unless $line;
+  
+  $range = 70 unless $range;
+  $symbol = ' ' unless $symbol;
+
+  my $result = '';
+  for (my $i = 0 ; $i <= int(length($line)/$range) ; $i++) {
+    $result .= substr($line,$i*$range,$range) . $symbol;
+  }
+  chop($result);
+  
+  return $result;
+}
+
+
+1;

local/cgi-bin/HTMLCleaner.pm

@@ -0,0 +1,207 @@
+#!/usr/bin/perl
+#
+
+package HTMLCleaner;
+
+use strict;
+use base 'HTML::Parser';
+use CSS::Cleaner;
+
+sub new {
+    my ($class, %opts) = @_;
+
+    my $p = new HTML::Parser('api_version' => 3);
+    $p->handler('start' =>  \&start, 'self, tagname, attr, attrseq, text' );
+    $p->handler('end' =>  \&end, 'self, tagname' );
+    $p->handler('text' =>  \&text, 'self, text' );
+    $p->handler('declaration' =>  \&decl, 'self, tokens' );
+
+    $p->{'output'}  = $opts{'output'} || sub {};
+    $p->{'cleaner'} = CSS::Cleaner->new;
+    $p->{'valid_stylesheet'} = $opts{'valid_stylesheet'} || sub { 1 };
+    $p->{'allow_password_input'} = $opts{'allow_password_input'} || 0;
+
+    bless $p, $class;
+}
+
+my %bad_attr = (map { $_ => 1 }
+                qw(datasrc datafld));
+
+my %eat_tag = (map { $_ => 1 }
+               qw(script iframe object applet embed param));
+
+my @eating;  # push tagname whenever we start eating a tag
+
+sub start {
+    my ($self, $tagname, $attr, $seq, $text) = @_;
+    $tagname =~ s/<//;
+
+    my $slashclose = 0;  # xml-style
+    if ($tagname =~ s!/(.*)!!) {
+        if (length($1)) { push @eating, "$tagname/$1"; } # basically halt parsing
+        else { $slashclose = 1; }
+    }
+
+    my @allowed_tags = ('lj-embed');
+
+    push @eating, $tagname if
+        $eat_tag{$tagname} && ! grep { lc $tagname eq $_ } @allowed_tags;
+
+    return if @eating;
+
+    my $clean_res = eval {
+        my $cleantag = $tagname;
+        $cleantag =~ s/^.*://s;
+        $cleantag =~ s/[^\w]//g;
+        no strict 'subs';
+        my $meth = "CLEAN_$cleantag";
+        my $code = $self->can($meth)
+            or return 1;  # don't clean, if no element-specific cleaner method
+        return $code->($self, $seq, $attr);
+    };
+    return if !$@ && !$clean_res;
+
+    my $ret = "<$tagname";
+    foreach (@$seq) {
+        if ($_ eq "/") { $slashclose = 1; next; }
+        next if $bad_attr{lc($_)};
+        next if /^on/i;
+        next if /(?:^=)|[\x0b\x0d]/;
+
+        if ($_ eq "style") {
+            $attr->{$_} = $self->{cleaner}->clean_property($attr->{$_});
+        }
+
+        if ($tagname eq 'input' && $_ eq 'type'  && $attr->{'type'} =~ /^password$/i && !$self->{'allow_password_input'}) {
+            delete $attr->{'type'};
+        }
+
+        my $nospace = $attr->{$_};
+        $nospace =~ s/[\s\0]//g;
+
+        # IE is brain-dead and lets javascript:, vbscript:, and about: have spaces mixed in
+        if ($nospace =~ /(?:(?:(?:vb|java)script)|about):/i) {
+            delete $attr->{$_};
+        }
+        $ret .= " $_=\"" . ehtml($attr->{$_}) . "\"";
+    }
+    $ret .= " /" if $slashclose;
+    $ret .= ">";
+
+    if ($tagname eq "style") {
+        $self->{'_eating_style'} = 1;
+        $self->{'_style_contents'} = "";
+    }
+
+    $self->{'output'}->($ret);
+}
+
+sub CLEAN_meta {
+    my ($self, $seq, $attr) = @_;
+
+    # don't allow refresh because it can refresh to javascript URLs
+    # don't allow content-type because they can set charset to utf-7
+    # why do we even allow meta tags?
+    my $equiv = lc $attr->{"http-equiv"};
+    if ($equiv) {
+        $equiv =~ s/[\s\x0b]//;
+        return 0 if $equiv =~ /refresh|content-type|link|set-cookie/;
+    }
+    return 1;
+}
+
+sub CLEAN_link {
+    my ($self, $seq, $attr) = @_;
+
+    if ($attr->{rel} =~ /\bstylesheet\b/i) {
+        my $href = $attr->{href};
+        return 0 unless $href =~ m!^https?://([^/]+?)(/.*)$!;
+        my ($host, $path) = ($1, $2);
+
+        my $rv = $self->{'valid_stylesheet'}->($href, $host, $path);
+        if ($rv == 1) {
+            return 1;
+        }
+        if ($rv) {
+            $attr->{href} = $rv;
+            return 1;
+        }
+        return 0;
+    }
+
+    # Allow blank <link> tags through so RSS S2 styles can work again without the 'rel="alternate"' hack
+    return 1 if (keys( %$attr ) == 0);
+
+    return 1 if $attr->{rel} =~ /^(?:service|openid)\.\w+$/;
+    my %okay = map { $_ => 1 } (qw(icon shortcut alternate next prev index made start search top help up author edituri file-list previous home contents bookmark chapter section subsection appendix glossary copyright child));
+    return 1 if $okay{lc($attr->{rel})};
+
+    # Allow link tags with only an href tag. This is an implied rel="alternate"
+    return 1 if (exists( $attr->{href} ) and (keys( %$attr ) == 1));
+
+    # Allow combinations of rel attributes through as long as all of them are valid, most notably "shortcut icon"
+    return 1 unless grep { !$okay{$_} } split( /\s+/, $attr->{rel} );
+
+    # unknown link tag
+    return 0;
+}
+
+sub end {
+    my ($self, $tagname) = @_;
+    if (@eating) {
+        pop @eating if $eating[-1] eq $tagname;
+        return;
+    }
+
+    if ($self->{'_eating_style'}) {
+        $self->{'_eating_style'} = 0;
+        $self->{'output'}->($self->{cleaner}->clean($self->{'_style_contents'}));
+    }
+
+    $self->{'output'}->("</$tagname>");
+}
+
+sub text {
+    my ($self, $text) = @_;
+    return if @eating;
+
+    if ($self->{'_eating_style'}) {
+        $self->{'_style_contents'} .= $text;
+        return;
+    }
+
+    # this string is magic [hack].  (See $out_straight in
+    # cgi-bin/LJ/S2.pm) callers can print "<!-- -->" to HTML::Parser
+    # just to make it flush, since HTML::Parser has no
+    # ->flush_outstanding text tag.
+    return if $text eq "<!-- -->";
+
+    # the parser gives us back text whenever it's confused
+    # on really broken input.  sadly, IE parses really broken
+    # input, so let's escape anything going out this way.
+    $self->{'output'}->(eangles($text));
+}
+
+sub decl {
+    my ($self, $tokens) = @_;
+    $self->{'output'}->("<!" . join(" ", map { eangles($_) } @$tokens) . ">");
+}
+
+sub eangles {
+    my $a = shift;
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    return $a;
+}
+
+sub ehtml {
+    my $a = shift;
+    $a =~ s/\&/&amp;/g;
+    $a =~ s/\"/&quot;/g;
+    $a =~ s/\'/&\#39;/g;
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    return $a;
+}
+
+1;

local/cgi-bin/LJ/Auth.pm

@@ -0,0 +1,124 @@
+# This is the LiveJournal Authentication module.
+# It contains useful authentication methods.
+
+package LJ::Auth;
+use strict;
+use Digest::HMAC_SHA1 qw(hmac_sha1_hex);
+use Digest::SHA1 qw(sha1_hex);
+use Carp qw (croak);
+
+# Generate an auth token for AJAX requests to use.
+# Arguments: ($remote, $action, %postvars)
+#   $remote: remote user object
+#   $uri: what uri this is for
+#   %postvars: the expected post variables
+# Returns: Auth token good for the current hour
+sub ajax_auth_token {
+    my ($class, $remote, $uri, %postvars) = @_;
+
+    $remote = LJ::want_user($remote) || LJ::get_remote();
+
+    croak "No URI specified" unless $uri;
+
+    my ($stime, $secret) = LJ::get_secret();
+    my $postvars = join('&', map { $postvars{$_} } sort keys %postvars);
+    my $remote_session_id = $remote && $remote->session ? $remote->session->id : LJ::UniqCookie->current_uniq;
+    my $remote_userid = $remote ? $remote->id : 0;
+
+    my $chalbare = qq {ajax:$stime:$remote_userid:$remote_session_id:$uri:$postvars};
+    my $chalsig = sha1_hex($chalbare, $secret);
+    return qq{$chalbare:$chalsig};
+}
+
+# Checks an auth token sent by an ajax request
+# Arguments: $remote, $uri, %POST variables
+# Returns: bool whether or not key is good
+sub check_ajax_auth_token {
+    my ($class, $remote, $uri, %postvars) = @_;
+
+    $remote = LJ::want_user($remote) || LJ::get_remote();
+
+    # get auth token out of post vars
+    my $auth_token = delete $postvars{auth_token} or return 0;
+
+    # recompute post vars
+    my $postvars = join('&', map { $postvars{$_} } sort keys %postvars);
+
+    # get vars out of token string
+    my ($c_ver, $stime, $remoteid, $sessid, $chal_uri, $chal_postvars, $chalsig) = split(':', $auth_token);
+
+    # get secret based on $stime
+    my $secret = LJ::get_secret($stime);
+
+    # no time?
+    return 0 unless $stime && $secret;
+
+    # right version?
+    return 0 unless $c_ver eq 'ajax';
+
+    # in logged-out case $remoteid is 0 and $sessid is uniq_cookie
+    my $req_remoteid = $remoteid > 0 ? $remote->id : 0;
+    my $req_sessid   = $remoteid > 0 ? $remote->session->id : LJ::UniqCookie->current_uniq;
+
+
+    # do signitures match?
+    my $chalbare = qq {$c_ver:$stime:$remoteid:$sessid:$chal_uri:$chal_postvars};
+    my $realsig = sha1_hex($chalbare, $secret);
+    return 0 unless $realsig eq $chalsig;
+
+    return 0 unless 
+        $remoteid == $req_remoteid && # remote id matches or logged-out 0=0
+        $sessid == $req_sessid &&     # remote sessid or logged-out uniq cookie match
+        $uri eq $chal_uri &&          # uri matches
+        $postvars eq $chal_postvars;  # post vars to uri
+
+    return 1;
+}
+
+# this is similar to the above methods but doesn't require a session or remote
+sub sessionless_auth_token {
+    my ($class, $uri, %reqvars) = @_;
+
+    croak "No URI specified" unless $uri;
+
+    my ($stime, $secret) = LJ::get_secret();
+    my $reqvars = join('&', map { $reqvars{$_} } sort keys %reqvars);
+
+    my $chalbare = qq {sessionless:$stime:$uri:$reqvars};
+    my $chalsig = sha1_hex($chalbare, $secret);
+    return qq{$chalbare:$chalsig};
+}
+
+sub check_sessionless_auth_token {
+    my ($class, $uri, %reqvars) = @_;
+
+    # get auth token out of post vars
+    my $auth_token = delete $reqvars{auth_token} or return 0;
+
+    # recompute post vars
+    my $reqvars = join('&', map { $reqvars{$_} } sort keys %reqvars);
+
+    # get vars out of token string
+    my ($c_ver, $stime, $chal_uri, $chal_reqvars, $chalsig) = split(':', $auth_token);
+
+    # get secret based on $stime
+    my $secret = LJ::get_secret($stime);
+
+    # no time?
+    return 0 unless $stime && $secret;
+
+    # right version?
+    return 0 unless $c_ver eq 'sessionless';
+
+    # do signitures match?
+    my $chalbare = qq {$c_ver:$stime:$chal_uri:$chal_reqvars};
+    my $realsig = sha1_hex($chalbare, $secret);
+    return 0 unless $realsig eq $chalsig;
+
+    # do other vars match?
+    return 0 unless $uri eq $chal_uri && $reqvars eq $chal_reqvars;
+
+    return 1;
+}
+
+1;

local/cgi-bin/LJ/CSS/Cleaner.pm

@@ -0,0 +1,21 @@
+package LJ::CSS::Cleaner;
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+use base 'CSS::Cleaner';
+
+sub new {
+    my $class = shift;
+    return $class->SUPER::new( @_,
+        pre_hook => sub {
+            my $rref = shift;
+
+            $$rref =~ s/comment-bake-cookie/CLEANED/g;
+            return;
+        },
+    );
+}
+
+1;

local/cgi-bin/LJ/ConvUTF8.pm

@@ -0,0 +1,47 @@
+# this is a small wrapper around Unicode::MapUTF8, just so we can lazily-load it easier
+# with Class::Autouse, and so we have a central place to init its charset aliases.
+# and in the future if we switch transcoding packages, we can just do it here.
+package LJ::ConvUTF8;
+
+use strict;
+use warnings;
+use Unicode::MapUTF8 ();
+
+BEGIN {
+    # declare some charset aliases
+    # we need this at least for cases when the only name supported
+    # by MapUTF8.pm isn't recognized by browsers
+    # note: newer versions of MapUTF8 know these
+    {
+        my %alias = ( 'windows-1251' => 'cp1251',
+                      'windows-1252' => 'cp1252',
+                      'windows-1253' => 'cp1253', );
+        foreach (keys %alias) {
+            next if Unicode::MapUTF8::utf8_supported_charset($_);
+            Unicode::MapUTF8::utf8_charset_alias($_, $alias{$_});
+        }
+    }
+}
+
+sub load {
+    1;
+}
+
+sub supported_charset {
+    my ($class, $charset) = @_;
+    return Unicode::MapUTF8::utf8_supported_charset($charset);
+}
+
+sub from_utf8 {
+    my ($class, $from_enc, $str) = @_;
+    return Unicode::MapUTF8::from_utf8({ -string=> $str, -charset => $from_enc });
+}
+
+sub to_utf8 {
+    my ($class, $to_enc, $str) = @_;
+    return Unicode::MapUTF8::to_utf8({ -string=> $str, -charset => $to_enc });
+}
+
+1;
+
+

local/cgi-bin/LJ/EmbedModule.pm

@@ -0,0 +1,466 @@
+#!/usr/bin/perl
+package LJ::EmbedModule;
+use strict;
+use Carp qw (croak);
+use Class::Autouse qw (
+                       LJ::Auth
+                       HTML::TokeParser
+                       );
+
+# states for a finite-state machine we use in parse()
+use constant {
+    # reading plain html without <object>, <embed> or <lj-embed>
+    REGULAR => 1,
+    # inside <object> or <embed> tag
+    IMPLICIT => 2,
+    # inside explicit <lj-embed> tag
+    EXPLICIT => 3,
+    # maximum embed width and height
+    MAX_WIDTH => 800,
+    MAX_HEIGHT => 800,
+};
+
+# can optionally pass in an id of a module to change its contents
+# returns module id
+sub save_module {
+    my ($class, %opts) = @_;
+
+    my $contents = $opts{contents} || '';
+    my $id       = $opts{id};
+    my $journal  = $opts{journal}
+        or croak "No journal passed to LJ::EmbedModule::save_module";
+    my $preview = $opts{preview};
+    
+    # are we creating a new entry?
+    unless (defined $id) {
+        $id = LJ::alloc_user_counter($journal, 'D')
+            or die "Could not allocate embed module ID";
+    } 
+
+    my $cmptext = 'C-' . LJ::text_compress($contents);
+
+    ## embeds for preview are stored in a special table, 
+    ## where new items overwrites old ones
+    my $table_name = ($preview) ? 'embedcontent_preview' : 'embedcontent';
+    $journal->do("REPLACE INTO $table_name (userid, moduleid, content) VALUES ".
+                "(?, ?, ?)", undef, $journal->{'userid'}, $id, $cmptext);
+    die $journal->errstr if $journal->err;
+    
+    # save in memcache
+    my $memkey = $class->memkey($journal->{'userid'}, $id, $preview);
+    LJ::MemCache::set($memkey, $contents);
+
+    return $id;
+}
+
+# changes <div class="ljembed"... tags from the RTE into proper lj-embed tags
+sub transform_rte_post {
+    my ($class, $txt) = @_;
+    return $txt unless $txt && $txt =~ /ljembed/i;
+    # ghetto... shouldn't use regexes to parse this
+    $txt =~ s/<div\s*class="ljembed"\s*(embedid="(\d+)")?\s*>(((?!<\/div>).)*)<\/div>/<lj-embed id="$2">$3<\/lj-embed>/ig;
+    $txt =~ s/<div\s*(embedid="(\d+)")?\s*class="ljembed"\s*>(((?!<\/div>).)*)<\/div>/<lj-embed id="$2">$3<\/lj-embed>/ig;
+    return $txt;
+}
+
+# takes a scalarref to entry text and expands lj-embed tags
+# REPLACE
+sub expand_entry {
+    my ($class, $journal, $entryref, %opts) = @_;
+
+    $$entryref =~ s/(<lj\-embed[^>]+\/>)/$class->_expand_tag($journal, $1, $opts{edit}, %opts)/ge;        
+}
+
+sub _expand_tag {
+    my $class = shift;
+    my $journal = shift;
+    my $tag = shift;
+    my $edit = shift;
+    my %opts = @_;
+    
+    my %attrs = $tag =~ /(\w+)="?(\-?\d+)"?/g;
+
+    return '[invalid lj-embed, id is missing]' unless $attrs{id};
+    
+    if ($edit) {
+        return '<lj-embed ' . join(' ', map {"$_=\"$attrs{$_}\""} keys %attrs) . ">\n" . 
+                 $class->module_content(moduleid  => $attrs{id}, journalid => $journal->id) . 
+                 "\n<\/lj-embed>";
+    }
+    elsif ($opts{'content_only'}) {
+      return $class->module_content(moduleid  => $attrs{id}, journalid => $journal->{'userid'});
+    }
+    else {
+        @opts{qw /width height/} = @attrs{qw/width height/};
+        return $class->module_iframe_tag($journal, $attrs{id}, %opts)
+    }            
+};
+
+
+# take a scalarref to a post, parses any lj-embed tags, saves the contents
+# of the tags and replaces them with a module tag with the id.
+# REPLACE
+sub parse_module_embed {
+    my ($class, $journal, $postref, %opts) = @_;
+
+    return unless $postref && $$postref;
+
+    return if LJ::conf_test($LJ::DISABLED{embed_module});
+
+    # fast track out if we don't have to expand anything
+    return unless $$postref =~ /lj\-embed|embed|object/i;
+
+    # do we want to replace with the lj-embed tags or iframes?
+    my $expand = $opts{expand};
+
+    # if this is editing mode, then we want to expand embed tags for editing
+    my $edit = $opts{edit};
+
+    # previews are a special case (don't want to permanantly save to db)
+    my $preview = $opts{preview};
+    
+    # deal with old-fashion calls
+    if (($edit || $expand) && ! $preview) {
+        return $class->expand_entry($journal, $postref, %opts);
+    } 
+    
+    # ok, we can safely parse post text
+    # machine state    
+    my $state = REGULAR;
+    my $p = HTML::TokeParser->new($postref);
+    my $newtxt = '';
+    my %embed_attrs = (); # ($eid, $ewidth, $eheight);
+    my $embed = '';
+    my @stack = ();
+    my $next_preview_id = 1;
+    
+    while (my $token = $p->get_token) {
+        my ($type, $tag, $attr) = @$token;
+        $tag = lc $tag;
+        my $newstate = undef;
+        my $reconstructed = $class->reconstruct($token);
+        
+        if ($state == REGULAR) {
+            if ($tag eq 'lj-embed' && $type eq 'S' && ! $attr->{'/'}) {
+                # <lj-embed ...>, not self-closed 
+                # switch to EXPLICIT state
+                $newstate = EXPLICIT;
+                # save embed id, width and height if they do exist in attributes
+                $embed_attrs{id} = $attr->{id} if $attr->{id};
+                $embed_attrs{width} = ($attr->{width} > MAX_WIDTH ? MAX_WIDTH : $attr->{width}) if $attr->{width};
+                $embed_attrs{height} = ($attr->{height} > MAX_HEIGHT ? MAX_HEIGHT : $attr->{height}) if $attr->{height};
+            } elsif (($tag eq 'object' || $tag eq 'embed') && $type eq 'S') {            
+                # <object> or <embed>
+                # switch to IMPLICIT state unless it is a self-closed tag
+                unless ($attr->{'/'}) {
+                    $newstate = IMPLICIT;
+                    # tag balance
+                    push @stack, $tag;
+                }
+                # append the tag contents to new embed buffer, so we can convert in to lj-embed later
+                $embed .= $reconstructed;
+            } else {
+                # otherwise stay in REGULAR
+                $newtxt .= $reconstructed;
+            }
+        } elsif ($state == IMPLICIT) {
+            if ($tag eq 'object' || $tag eq 'embed') {
+                if ($type eq 'E') {
+                    # </object> or </embed>
+                    # update tag balance, but only if we have a valid balance up to this moment
+                    pop @stack if $stack[-1] eq $tag;
+                    # switch to REGULAR if tags are balanced (stack is empty), stay in IMPLICIT otherwise
+                    $newstate = REGULAR unless @stack;
+                } elsif ($type eq 'S') {
+                    # <object> or <embed>
+                    # mind the tag balance, do not update it in case of a self-closed tag
+                    push @stack, $tag unless $attr->{'/'};
+                }
+            }
+            # append to embed buffer
+            $embed .= $reconstructed;                
+            
+        } elsif ($state == EXPLICIT) {
+
+            if ($tag eq 'lj-embed' && $type eq 'E') {
+                # </lj-embed> - that's the end of explicit embed block, switch to REGULAR
+                $newstate = REGULAR;
+            } else {
+                # continue appending contents to embed buffer
+                $embed .= $reconstructed;
+            }
+        } else {
+            # let's be paranoid
+            die "Invalid state: '$state'";
+        }
+        
+        # we decided to switch back to REGULAR and have something in embed buffer
+        # so let's save buffer as an embed module and start all over again
+        if (defined($newstate) && $newstate == REGULAR && $embed) {
+            $embed_attrs{id} = $class->save_module(
+                id => ($preview ? $next_preview_id++ : $embed_attrs{id}),
+                contents => $embed,
+                journal  => $journal,
+                preview => $preview,
+            );
+                        
+            $newtxt .= "<lj-embed " . join(' ', map { exists $embed_attrs{$_} ? "$_=\"$embed_attrs{$_}\"" : () } qw / id width height /) . "/>";
+            
+            $embed = '';
+            %embed_attrs = ();
+        }
+        
+        # switch the state if we have a new one
+        $state = $newstate if defined $newstate;
+        
+    }    
+
+    # update passed text
+    $$postref = $newtxt;
+}
+
+sub module_iframe_tag {
+    my ($class, $u, $moduleid, %opts) = @_;
+
+    return '' if $LJ::DISABLED{embed_module};
+
+    my $journalid = $u->{'userid'};
+    $moduleid += 0;
+
+    # parse the contents of the module and try to come up with a guess at the width and height of the content
+    my $content = $class->module_content(moduleid => $moduleid, journalid => $journalid);
+    my $preview = $opts{preview};
+    my $width = 0;
+    my $height = 0;
+    my $p = HTML::TokeParser->new(\$content);
+    my $embedcodes;
+    
+    # if the content only contains a whitelisted embedded video
+    # then we can skip the placeholders (in some cases)
+    my $no_whitelist = 0;
+    my $found_embed = 0;
+
+    # we don't need to estimate the dimensions if they are provided in tag attributes
+    unless ($opts{width} && $opts{height}) {
+        while (my $token = $p->get_token) {
+            my $type = $token->[0];
+            my $tag  = $token->[1] ? lc $token->[1] : '';
+            my $attr = $token->[2];  # hashref
+    
+            if ($type eq "S") {
+                my ($elewidth, $eleheight);
+    
+                if ($attr->{width}) {
+                    $elewidth = $attr->{width}+0;
+                    $width = $elewidth if $elewidth > $width;
+                }
+                if ($attr->{height}) {
+                    $eleheight = $attr->{height}+0;
+                    $height = $eleheight if $eleheight > $height;
+                }
+    
+                my $flashvars = $attr->{flashvars};
+    
+                if ($tag eq 'object' || $tag eq 'embed') {
+                    my $src;
+                    next unless $src = $attr->{src};
+    
+                    # we have an object/embed tag with src, make a fake lj-template object
+                    my @tags = (
+                                ['S', 'lj-template', {
+                                    name => 'video',
+                                    (defined $elewidth     ? ( width  => $width  ) : ()),
+                                    (defined $eleheight    ? ( height => $height ) : ()),
+                                    (defined $flashvars ? ( flashvars => $flashvars ) : ()),
+                                }],
+                                [ 'T', $src, {}],
+                                ['E', 'lj-template', {}],
+                                );
+    
+                    $embedcodes = LJ::run_hook('expand_template_video', \@tags);
+    
+                    $found_embed = 1 if $embedcodes;
+                    $found_embed &&= $embedcodes !~ /Invalid video/i;
+    
+                    $no_whitelist = !$found_embed;
+                } elsif ($tag ne 'param') {
+                    $no_whitelist = 1;
+                }
+            }
+        }
+    
+        # add padding
+        $width += 50 if $width;
+        $height += 50 if $height;
+    } 
+    
+    # use explicit values if we have them
+    $width = $opts{width} if $opts{width};
+    $height = $opts{height} if $opts{height};
+
+    $width ||= 240;
+    $height ||= 200;
+
+    # some dimension min/maxing
+    $width = 50 if $width < 50;
+    $width = MAX_WIDTH if $width > MAX_WIDTH;
+    $height = 50 if $height < 50;
+    $height = MAX_HEIGHT if $height > MAX_HEIGHT;
+
+    # safari caches state of sub-resources aggressively, so give
+    # each iframe a unique 'name' attribute
+    my $id = qq(name="embed_${journalid}_$moduleid");
+
+    my $auth_token = LJ::eurl(LJ::Auth->sessionless_auth_token('embedcontent', moduleid => $moduleid, journalid => $journalid, preview => $preview,));
+    my $iframe_url = qq {http://$LJ::EMBED_MODULE_DOMAIN/tools/embedcontent.bml?journalid=$journalid&moduleid=$moduleid&preview=$preview&auth_token=$auth_token};
+    my $iframe_tag = qq {<iframe src="$iframe_url" } .
+        qq{width="$width" height="$height" allowtransparency="true" frameborder="0" class="lj_embedcontent" $id></iframe>};
+
+    my $remote = LJ::get_remote();
+    my $do_placeholder;
+    
+    if ($remote) {
+	return $iframe_tag if $opts{edit};
+  
+	# show placeholder instead of iframe?
+	LJ::load_user_props($remote, "opt_embedplaceholders");
+	my $placeholder_prop = $remote->prop('opt_embedplaceholders');
+	$do_placeholder = $placeholder_prop && $placeholder_prop ne 'N';
+
+	# if placeholder_prop is not set, then show placeholder on a friends
+        # page view UNLESS the embedded content is only one embed/object
+        # tag and it's whitelisted video.
+        my $r = eval { Apache->request };
+        my $view = $r ? $r->notes("view") : '';
+        if (! $placeholder_prop && $view eq 'friends') {
+            # show placeholder if this is not whitelisted video
+            $do_placeholder = 1 if $no_whitelist;
+        }
+    }
+    else {
+	$do_placeholder = $BML::COOKIE{'flashpref'};
+	$do_placeholder = 0 unless $do_placeholder eq "0" || $do_placeholder eq "1";
+    }
+    
+    return $iframe_tag unless $do_placeholder;
+
+    my $tmpcontent = $class->module_content(
+  journalid => $journalid,
+  moduleid  => $moduleid,
+  0
+  );
+    $tmpcontent =~ s/.+param\s+name\s*?=\s*?"?movie"?\s*value\s*?=\s*?"?//sg; #"
+    $tmpcontent =~ s/("|\s).+//sg; #"
+    $tmpcontent = LJ::ehtml($tmpcontent);
+
+    # placeholder
+    return LJ::placeholder_link(
+                                placeholder_html => $iframe_tag,
+        placeholder_link => $iframe_url,
+                                width            => $width,
+                                height           => $height,
+                                img              => "$LJ::IMGPREFIX/videoplaceholder.png",
+        img_title => $tmpcontent,
+                                );
+}
+
+sub module_content {
+    my ($class, %opts) = @_;
+
+    my $moduleid  = $opts{moduleid};
+    croak "No moduleid" unless defined $moduleid;
+    $moduleid += 0;
+
+    my $journalid = $opts{journalid}+0 or croak "No journalid";
+    my $journal = LJ::load_userid($journalid) or die "Invalid userid $journalid";
+    my $preview = $opts{preview};
+
+    # try memcache
+    my $memkey = $class->memkey($journalid, $moduleid, $preview);
+    my $content = LJ::MemCache::get($memkey);
+    my ($dbload, $dbid); # module id from the database
+    unless (defined $content) {
+        my $table_name = ($preview) ? 'embedcontent_preview' : 'embedcontent';
+        ($content, $dbid) = $journal->selectrow_array("SELECT content, moduleid FROM $table_name WHERE " .
+                                                      "moduleid=? AND userid=?",
+                                                      undef, $moduleid, $journalid);
+        die $journal->errstr if $journal->err;
+        $dbload = 1;
+    }
+
+    $content ||= '';
+
+    LJ::text_uncompress(\$content) if $content =~ s/^C-//;
+
+    # clean js out of content
+    unless ($LJ::DISABLED{'embedmodule-cleancontent'}) {
+        LJ::CleanHTML::clean(\$content, {
+            addbreaks => 0,
+            tablecheck => 0,
+            mode => 'allow',
+            allow => [qw(object embed)],
+            deny => [qw(script iframe)],
+            remove => [qw(script iframe)],
+            ljcut_disable => 1,
+            cleancss => 0,
+            extractlinks => 0,
+            noautolinks => 1,
+            extractimages => 0,
+            noexpandembedded => 1,
+            transform_embed_nocheck => 1,
+        });
+    }
+
+    # if we got stuff out of database
+    if ($dbload) {
+        # save in memcache
+        LJ::MemCache::set($memkey, $content);
+
+        # if we didn't get a moduleid out of the database then this entry is not valid
+        return defined $dbid ? $content : "[Invalid lj-embed id $moduleid]";
+    }
+
+    # get rid of whitespace around the content
+    return LJ::trim($content) || '';
+}
+
+sub memkey {
+    my ($class, $journalid, $moduleid, $preview) = @_;
+    my $pfx = $preview ? 'embedcontpreview' : 'embedcont';
+    return [$journalid, "$pfx:$journalid:$moduleid"];
+}
+
+# create a tag string from HTML::TokeParser token
+sub reconstruct {
+    my $class = shift;
+    my $token = shift;
+    my ($type, $tag, $attr, $attord) = @$token;
+    if ($type eq 'S') {
+        my $txt = "<$tag";
+        my $selfclose;
+    
+        # preserve order of attributes. the original order is
+        # in element 4 of $token
+        foreach my $name (@$attord) {
+            if ($name eq '/') {
+                $selfclose = 1;
+                next;
+            }
+    
+            # FIXME: ultra ghetto.
+            $attr->{$name} = LJ::no_utf8_flag($attr->{$name});
+    
+            $txt .= " $name=\"" . LJ::ehtml($attr->{$name}) . "\"";
+        }
+        $txt .= $selfclose ? " />" : ">";    
+        
+    } elsif ($type eq 'E') {
+        return "</$tag>";
+    } else { # C, T, D or PI
+        return $tag;
+    }
+}
+
+
+1;
+

local/cgi-bin/LJ/OpenID.pm

@@ -0,0 +1,184 @@
+package LJ::OpenID;
+
+use strict;
+use Digest::SHA1 qw(sha1 sha1_hex);
+use LWPx::ParanoidAgent;
+
+BEGIN {
+    $LJ::OPTMOD_OPENID_CONSUMER = $LJ::OPENID_CONSUMER ? eval "use Net::OpenID::Consumer; 1;" : 0;
+    $LJ::OPTMOD_OPENID_SERVER   = $LJ::OPENID_SERVER   ? eval "use Net::OpenID::Server; 1;" : 0;
+}
+
+# returns boolean whether consumer support is enabled and available
+sub consumer_enabled {
+    return 0 unless $LJ::OPENID_CONSUMER;
+    return $LJ::OPTMOD_OPENID_CONSUMER || eval "use Net::OpenID::Consumer; 1;";
+}
+
+# returns boolean whether consumer support is enabled and available
+sub server_enabled {
+    return 0 unless $LJ::OPENID_SERVER;
+    return $LJ::OPTMOD_OPENID_CONSUMER || eval "use Net::OpenID::Server; 1;";
+}
+
+sub server {
+    my ($get, $post) = @_;
+
+    return Net::OpenID::Server->new(
+                                    compat       => $LJ::OPENID_COMPAT,
+                                    get_args     => $get  || {},
+                                    post_args    => $post || {},
+
+                                    get_user     => \&LJ::get_remote,
+                                    is_identity  => sub {
+                                        my ($u, $ident) = @_;
+                                        return LJ::OpenID::is_identity($u, $ident, $get);
+                                    },
+                                    is_trusted   => \&LJ::OpenID::is_trusted,
+
+                                    setup_url    => "$LJ::SITEROOT/openid/approve.bml",
+
+                                    server_secret => \&LJ::OpenID::server_secret,
+                                    secret_gen_interval => 3600,
+                                    secret_expire_age   => 86400 * 14,
+                                    );
+}
+
+# Returns a Consumer object
+# When planning to verify identity, needs GET
+# arguments passed in
+sub consumer {
+    my $get_args = shift || {};
+
+    my $ua;
+    unless ($LJ::IS_DEV_SERVER) {
+        $ua = LWPx::ParanoidAgent->new(
+                                       timeout => 10,
+                                       max_size => 1024*300,
+                                       );
+    }
+
+    my $csr = Net::OpenID::Consumer->new(
+                                         ua => $ua,
+                                         args => $get_args,
+                                         cache => eval { LJ::MemCache::get_memcache() },
+                                         consumer_secret => \&LJ::OpenID::consumer_secret,
+                                         debug => $LJ::IS_DEV_SERVER || 0,
+                                         required_root => $LJ::SITEROOT,
+                                         );
+
+    return $csr;
+}
+
+sub consumer_secret {
+    my $time = shift;
+    return server_secret($time - $time % 3600);
+}
+
+sub server_secret {
+    my $time = shift;
+    my ($t2, $secret) = LJ::get_secret($time);
+    die "ASSERT: didn't get t2 (t1=$time)" unless $t2;
+    die "ASSERT: didn't get secret (t2=$t2)" unless $secret;
+    die "ASSERT: time($time) != t2($t2)\n" unless $t2 == $time;
+    return $secret;
+}
+
+sub is_trusted {
+    my ($u, $trust_root, $is_identity) = @_;
+    return 0 unless $u;
+    # we always look up $is_trusted, even if $is_identity is false, to avoid timing attacks
+
+    my $dbh = LJ::get_db_writer();
+    my ($endpointid, $duration) = $dbh->selectrow_array("SELECT t.endpoint_id, t.duration ".
+                                                        "FROM openid_trust t, openid_endpoint e ".
+                                                        "WHERE t.userid=? AND t.endpoint_id=e.endpoint_id AND e.url=?",
+                                                        undef, $u->{userid}, $trust_root);
+    return 0 unless $endpointid;
+    return 1;
+}
+
+sub is_identity {
+    my ($u, $ident, $get) = @_;
+    return 0 unless $u && $u->{journaltype} eq "P";
+
+    my $user = $u->{user};
+    return 1 if
+        $ident eq "$LJ::SITEROOT/users/$user/" ||
+        $ident eq "$LJ::SITEROOT/~$user/" ||
+        $ident eq "http://$user.$LJ::USER_DOMAIN/";
+
+    return 0;
+}
+
+sub getmake_endpointid {
+    my $site = shift;
+
+    my $dbh = LJ::get_db_writer()
+        or return undef;
+
+    my $rv = $dbh->do("INSERT IGNORE INTO openid_endpoint (url) VALUES (?)", undef, $site);
+    my $end_id;
+    if ($rv > 0) {
+        $end_id = $dbh->{'mysql_insertid'};
+    } else {
+        $end_id = $dbh->selectrow_array("SELECT endpoint_id FROM openid_endpoint WHERE url=?",
+                                        undef, $site);
+    }
+    return $end_id;
+}
+
+sub add_trust {
+    my ($u, $site) = @_;
+
+    my $end_id = LJ::OpenID::getmake_endpointid($site)
+        or return 0;
+
+    my $dbh = LJ::get_db_writer()
+        or return undef;
+
+    my $rv = $dbh->do("REPLACE INTO openid_trust (userid, endpoint_id, duration, trust_time) ".
+                      "VALUES (?,?,?,UNIX_TIMESTAMP())", undef, $u->{userid}, $end_id, "always");
+    return $rv;
+}
+
+# From Digest::HMAC
+sub hmac_sha1_hex {
+    unpack("H*", &hmac_sha1);
+}
+sub hmac_sha1 {
+    hmac($_[0], $_[1], \&sha1, 64);
+}
+sub hmac {
+    my($data, $key, $hash_func, $block_size) = @_;
+    $block_size ||= 64;
+    $key = &$hash_func($key) if length($key) > $block_size;
+
+    my $k_ipad = $key ^ (chr(0x36) x $block_size);
+    my $k_opad = $key ^ (chr(0x5c) x $block_size);
+
+    &$hash_func($k_opad, &$hash_func($k_ipad, $data));
+}
+
+# Returns 1 if destination identity server
+# is blocked
+sub blocked_hosts {
+    my $csr = shift;
+
+    return do { my $dummy = 0; \$dummy; } if $LJ::IS_DEV_SERVER;
+
+    my $tried_local_id = 0;
+    $csr->ua->blocked_hosts(
+                            sub {
+                                my $dest = shift;
+
+                                if ($dest =~ /((^|\.)\Q$LJ::DOMAIN\E$|demotivation\.me|anonymity\.com)/i) {
+                                    $tried_local_id = 1;
+                                    return 1;
+                                }
+                                return 0;
+                            });
+    return \$tried_local_id;
+}
+
+1;

local/cgi-bin/LJ/S2/DayPage.pm

@@ -0,0 +1,232 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+sub DayPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "DayPage";
+    $p->{'view'} = "day";
+    $p->{'entries'} = [];
+
+    my $user = $u->{'user'};
+    my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
+            "/calendar" . $opts->{'pathextra'};
+        return 1;
+    }
+
+    if ($u->{'opt_blockrobots'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+
+    my $get = $opts->{'getargs'};
+
+    my $month = $get->{'month'};
+    my $day = $get->{'day'};
+    my $year = $get->{'year'};
+    my @errors = ();
+
+    if ($opts->{'pathextra'} =~ m!^/(\d\d\d\d)/(\d\d)/(\d\d)\b!) {
+        ($month, $day, $year) = ($2, $3, $1);
+    }
+    
+    $opts->{'errors'} = [];
+    if ($year !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant year."; }
+    if ($month !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant month."; }
+    if ($day !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant day."; }
+    if ($month < 1 || $month > 12 || int($month) != $month) { push @{$opts->{'errors'}}, "Invalid month."; }
+    if ($year < 1970 || $year > 2038 || int($year) != $year) { push @{$opts->{'errors'}}, "Invalid year: $year"; }
+    if ($day < 1 || $day > 31 || int($day) != $day) { push @{$opts->{'errors'}}, "Invalid day."; }
+    if (scalar(@{$opts->{'errors'}})==0 && $day > LJ::days_in_month($month, $year)) { push @{$opts->{'errors'}}, "That month doesn't have that many days."; }
+    return if @{$opts->{'errors'}};
+
+    $p->{'date'} = Date($year, $month, $day);
+    # mysqldate_to_time():  ^(\d\d\d\d)-(\d\d)-(\d\d)(?: (\d\d):(\d\d)(?::(\d\d))?)?$/  -> unixtime, with check.
+    # why not using get_recent_items() ?
+
+#use Time::HiRes qw(gettimeofday tv_interval);
+#my $t0 = [gettimeofday];
+#my @elapsed;
+#push @elapsed, (tv_interval ($t0));
+#print STDERR "@elapsed \n";
+    
+    my $secwhere = "AND security='public'";
+    my $viewall = 0;
+    my $viewsome = 0; # see public posts from suspended users
+    if ($remote) {
+
+        # do they have the viewall priv?
+        if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
+            LJ::statushistory_add($u->{'userid'}, $remote->{'userid'}, 
+                                  "viewall", "day: $user, statusvis: $u->{'statusvis'}");
+            $viewall = LJ::check_priv($remote, 'canview', '*');
+            $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+        }
+
+        if ($remote->{'userid'} == $u->{'userid'} || $viewall) {
+            $secwhere = "";   # see everything
+        } elsif ($remote->{'journaltype'} eq 'P' || $remote->{'journaltype'} eq 'I') {
+            my $gmask = LJ::get_groupmask($u, $remote);
+            $secwhere = "AND (security='public' OR (security='usemask' AND allowmask & $gmask))"
+                if $gmask;
+        }
+    }
+
+    my $dbcr = LJ::get_cluster_reader($u);
+    unless ($dbcr) {
+        push @{$opts->{'errors'}}, "Database temporarily unavailable";
+        return;
+    }
+
+    # load the log items
+    my $dateformat = "%Y %m %d %H %i %s %w"; # yyyy mm dd hh mm ss day_of_week
+    my $sth = $dbcr->prepare("SELECT jitemid AS itemid, posterid, security, DATE_FORMAT(eventtime, \"$dateformat\") AS 'alldatepart', anum ".
+                             "FROM log2 " .
+                             "WHERE journalid=$u->{'userid'} AND year=$year AND month=$month AND day=$day $secwhere " . 
+                             "ORDER BY eventtime, logtime LIMIT 200");
+    $sth->execute;
+
+    my @items;
+    push @items, $_ while $_ = $sth->fetchrow_hashref;
+#push @elapsed, (tv_interval ($t0));
+
+    LJ::fill_items_with_text_props(\@items, $u);
+
+    # load 'opt_ljcut_disable_lastn' prop for $remote.
+    LJ::load_user_props($remote, "opt_ljcut_disable_lastn");
+    
+    my (%apu, %apu_lite);  # alt poster users; UserLite objects
+    foreach (@items) {
+        next unless $_->{'posterid'} != $u->{'userid'};
+        $apu{$_->{'posterid'}} = undef;
+    }
+    if (%apu) {
+        LJ::load_userids_multiple([map { $_, \$apu{$_} } keys %apu], [$u]);
+        $apu_lite{$_} = UserLite($apu{$_}) foreach keys %apu;
+    }
+
+    my $userlite_journal = UserLite($u);
+#push @elapsed, (tv_interval ($t0));
+
+  ENTRY:
+    foreach my $item (@items)
+    {
+        my ($posterid, $itemid, $security, $alldatepart, $anum) = 
+            map { $item->{$_} } qw(posterid itemid security alldatepart anum);
+
+        my $props = $item->{'props'};
+
+        my $replycount = $props->{'replycount'};
+        my $subject = $item->{'text'}->[0];
+        my $text    = $item->{'text'}->[1];
+        if ($get->{'nohtml'}) {
+            # quote all non-LJ tags
+            $subject =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+            $text    =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+        }
+
+        # don't show posts from suspended users
+        next ENTRY if $apu{$posterid} && $apu{$posterid}->{'statusvis'} eq 'S' && ! $viewsome;
+
+        LJ::CleanHTML::clean_subject(\$subject) if $subject;
+
+        my $ditemid = $itemid*256 + $anum;
+
+        LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $props->{'opt_preformatted'},
+                                             'cuturl' => LJ::item_link($u, $itemid, $anum),
+                                             'ljcut_disable' => $remote->{'opt_ljcut_disable_lastn'}, });
+        LJ::expand_embedded($u, $ditemid, $remote, \$text);
+
+        my $nc = "";
+        $nc .= "nc=$replycount" if $replycount; # && $remote && $remote->{'opt_nctalklinks'};
+
+        my $permalink = "$journalbase/$ditemid.html";
+        my $readurl = $permalink;
+        $readurl .= "?$nc" if $nc;
+        my $posturl = $permalink . "?mode=reply";
+
+        my $comments = CommentInfo({
+            'read_url' => $readurl,
+            'post_url' => $posturl,
+            'count' => $replycount,
+            'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
+            'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $props->{'opt_nocomments'}) ? 1 : 0,
+            'screened' => ($props->{'hasscreened'} && $remote &&
+                           ($remote->{'user'} eq $u->{'user'} || LJ::can_manage($remote, $u))) ? 1 : 0,
+        });
+
+        my $userlite_poster = $userlite_journal;
+        my $pu = $u;
+        if ($u->{'userid'} != $posterid) {
+            $userlite_poster = $apu_lite{$posterid} or die "No apu_lite for posterid=$posterid";
+            $pu = $apu{$posterid};
+        }
+        my $userpic = Image_userpic($pu, 0, $props->{'picture_keyword'});
+
+        my $entry = Entry($u, {
+            'subject' => $subject,
+            'text' => $text,
+            'dateparts' => $alldatepart,
+            'security' => $security,
+            'props' => $props,
+            'itemid' => $ditemid,
+            'journal' => $userlite_journal,
+            'poster' => $userlite_poster,
+            'comments' => $comments,
+            'userpic' => $userpic,
+            'permalink_url' => $permalink,
+            'enable_tags_compatibility' => [$opts->{enable_tags_compatibility}, $opts->{ctx}],
+        });
+
+        push @{$p->{'entries'}}, $entry;
+    }
+#push @elapsed, (tv_interval ($t0));
+#print STDERR "@elapsed \n";
+
+
+    if (@{$p->{'entries'}}) {
+        $p->{'has_entries'} = 1;
+        $p->{'entries'}->[0]->{'new_day'} = 1;
+        $p->{'entries'}->[-1]->{'end_day'} = 1;
+    }
+
+    # calculate previous day
+    my $pdyear = $year;
+    my $pdmonth = $month;
+    my $pdday = $day-1;
+    if ($pdday < 1)
+    {
+        if (--$pdmonth < 1)
+        {
+          $pdmonth = 12;
+          $pdyear--;
+        }
+        $pdday = LJ::days_in_month($pdmonth, $pdyear);
+    }
+
+    # calculate next day
+    my $nxyear = $year;
+    my $nxmonth = $month;
+    my $nxday = $day+1;
+    if ($nxday > LJ::days_in_month($nxmonth, $nxyear))
+    {
+        $nxday = 1;
+        if (++$nxmonth > 12) { ++$nxyear; $nxmonth=1; }
+    }
+    
+    $p->{'prev_url'} = "$u->{'_journalbase'}/" . sprintf("%04d/%02d/%02d/", $pdyear, $pdmonth, $pdday); 
+    $p->{'prev_date'} = Date($pdyear, $pdmonth, $pdday);
+    $p->{'next_url'} = "$u->{'_journalbase'}/" . sprintf("%04d/%02d/%02d/", $nxyear, $nxmonth, $nxday); 
+    $p->{'next_date'} = Date($nxyear, $nxmonth, $nxday);
+
+    return $p;
+}
+
+1;

local/cgi-bin/LJ/S2/EntryPage.pm

@@ -0,0 +1,432 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+sub EntryPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $get = $opts->{'getargs'};
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "EntryPage";
+    $p->{'view'} = "entry";
+    $p->{'comments'} = [];
+    $p->{'comment_pages'} = undef;
+
+    # setup viewall options
+    my ($viewall, $viewsome) = (0, 0);
+    if ($get->{viewall} && LJ::check_priv($remote, 'canview')) {
+        # we don't log here, as we don't know what entry we're viewing yet.  the logging
+        # is done when we call EntryPage_entry below.
+        $viewall = LJ::check_priv($remote, 'canview', '*');
+        $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+    }
+
+    my ($entry, $s2entry) = EntryPage_entry($u, $remote, $opts);
+    return if $opts->{'suspendeduser'};
+    return if $opts->{'handler_return'};
+
+    $p->{'multiform_on'} = $remote &&
+        ($remote->{'userid'} == $u->{'userid'} ||
+         $remote->{'userid'} == $entry->{'posterid'} ||
+         LJ::can_manage($remote, $u));
+
+    my $itemid = $entry->{'itemid'};
+    my $ditemid = $entry->{'itemid'} * 256 + $entry->{'anum'};
+    my $permalink = LJ::journal_base($u) . "/$ditemid.html";
+    my $stylemine = $get->{'style'} eq "mine" ? "style=mine" : "";
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
+            "/$ditemid.html" . $opts->{'pathextra'};
+        return 1;
+    }
+
+    if ($u->{'opt_blockrobots'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+    if ($LJ::UNICODE) {
+        $p->{'head_content'} .= '<meta http-equiv="Content-Type" content="text/html; charset='.$opts->{'saycharset'}."\" />\n";
+    }
+
+    $p->{'entry'} = $s2entry;
+
+    # add the comments
+    my %userpic;
+    my %user;
+    my $copts = {
+        'thread' => ($get->{'thread'} >> 8),
+        'page' => $get->{'page'},
+        'view' => $get->{'view'},
+        'userpicref' => \%userpic,
+        'userref' => \%user,
+        # user object is cached from call just made in EntryPage_entry
+        'up' => LJ::load_user($s2entry->{'poster'}->{'username'}),
+        'viewall' => $viewall,
+
+	# Okuklivanie tredov - daem upravlenie pol'zovatelyu -
+        'page_size' => $get->{'page_size'},
+        'max_subjects' => $get->{'max_subjects'},
+        'threading_point' => $get->{'threading_point'},
+        'uncollapse' => $get->{'uncollapse'},
+    };
+
+    my $userlite_journal = UserLite($u);
+
+    my @comments = LJ::Talk::load_comments($u, $remote, "L", $itemid, $copts);
+
+    my $pics = LJ::Talk::get_subjecticons()->{'pic'};  # hashref of imgname => { w, h, img }
+    my $convert_comments = sub {
+        my ($self, $destlist, $srclist, $depth) = @_;
+
+        foreach my $com (@$srclist) {
+            my $dtalkid = $com->{'talkid'} * 256 + $entry->{'anum'};
+            my $text = $com->{'body'};
+            if ($get->{'nohtml'}) {
+                # quote all non-LJ tags
+                $text =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+            }
+            LJ::CleanHTML::clean_comment(\$text, { 'preformatted' => $com->{'props'}->{'opt_preformatted'}, 
+                                                   'anon_comment' => !$com->{posterid}});
+
+            # local time in mysql format to gmtime
+	    my $datetime = DateTime_unix(LJ::mysqldate_to_time($com->{'datepost'}));
+	    if ($datetime == 0) {
+	      $datetime = "Invalid date";
+	    }
+	    
+            my $subject_icon = undef;
+            if (my $si = $com->{'props'}->{'subjecticon'}) {
+                my $pic = $pics->{$si};
+                $subject_icon = Image("$LJ::IMGPREFIX/talk/$pic->{'img'}",
+                                      $pic->{'w'}, $pic->{'h'}) if $pic;
+            }
+
+            my $comment_userpic;
+            if (my $pic = $userpic{$com->{'picid'}}) {
+                $comment_userpic = Image("$LJ::USERPIC_ROOT/$com->{'picid'}/$pic->{'userid'}",
+                                         $pic->{'width'}, $pic->{'height'});
+            }
+
+            my $reply_url = LJ::Talk::talkargs($permalink, "replyto=$dtalkid", $stylemine);
+
+            my $par_url;
+            if ($com->{'parenttalkid'}) {
+                my $dparent = ($com->{'parenttalkid'} << 8) + $entry->{'anum'};
+                $par_url = LJ::Talk::talkargs($permalink, "thread=$dparent", $stylemine) . "#t$dparent";
+            }
+
+            my $poster;
+            if ($com->{'posterid'}) {
+                if ($user{$com->{'posterid'}}) {
+                    $poster = UserLite($user{$com->{'posterid'}});
+                } else {
+                    $poster = {
+                        '_type' => 'UserLite',
+                        'username' => $com->{'userpost'},
+                        'name' => $com->{'userpost'},  # we don't have this, so fake it
+                        'journal_type' => 'P',         # fake too, but only people can post, so correct
+                    };
+                }
+            }
+
+            my $s2com = {
+                '_type' => 'Comment',
+                'journal' => $userlite_journal,
+                'metadata' => {
+                    'picture_keyword' => $com->{'props'}->{'picture_keyword'},
+                },
+                'permalink_url' => "$permalink?thread=$dtalkid#t$dtalkid",
+                'reply_url' => $reply_url,
+                'poster' => $poster,
+                'replies' => [],
+                'subject' => LJ::ehtml($com->{'subject'}),
+                'subject_icon' => $subject_icon,
+                'talkid' => $dtalkid,
+                'text' => $text,
+                'userpic' => $comment_userpic,
+                'time' => $datetime,
+                'tags' => [],
+                'full' => $com->{'_loaded'} ? 1 : 0,
+                'depth' => $depth,
+                'parent_url' => $par_url,
+                'screened' => $com->{'state'} eq "S" ? 1 : 0,
+                'frozen' => $com->{'state'} eq "F" ? 1 : 0,
+                'link_keyseq' => [ 'delete_comment' ],
+                'anchor' => "t$dtalkid",
+                'dom_id' => "ljcmt$dtalkid",
+            };
+
+            # don't show info from suspended users
+            # FIXME: ideally the load_comments should only return these
+            # items if there are children, otherwise they should be hidden entirely
+            my $pu = $com->{'posterid'} ? $user{$com->{'posterid'}} : undef;
+            if ($pu && $pu->{'statusvis'} eq "S" && !$viewsome) {
+                $s2com->{'text'} = "";
+                $s2com->{'subject'} = "";
+                $s2com->{'full'} = 0;
+                $s2com->{'subject_icon'} = undef;
+                $s2com->{'userpic'} = undef;
+            }
+
+            # Conditionally add more links to the keyseq
+            my $link_keyseq = $s2com->{'link_keyseq'};
+            push @$link_keyseq, $s2com->{'screened'} ? 'unscreen_comment' : 'screen_comment';
+            push @$link_keyseq, $s2com->{'frozen'} ? 'unfreeze_thread' : 'freeze_thread';
+
+            if (@{$com->{'children'}}) {
+                $s2com->{'thread_url'} = LJ::Talk::talkargs($permalink, "thread=$dtalkid", $stylemine) . "#t$dtalkid";
+            }                    
+
+            # add the poster_ip metadata if remote user has 
+            # access to see it.
+            $s2com->{'metadata'}->{'poster_ip'} = $com->{'props'}->{'poster_ip'} if 
+                ($com->{'props'}->{'poster_ip'} && $remote &&
+                 ($remote->{'userid'} == $entry->{'posterid'} ||
+                  LJ::can_manage($remote, $u) || $viewall));
+            
+            push @$destlist, $s2com;
+
+            $self->($self, $s2com->{'replies'}, $com->{'children'}, $depth+1);
+        }
+    };
+    $p->{'comments'} = [];
+    $convert_comments->($convert_comments, $p->{'comments'}, \@comments, 1);
+
+    # prepare the javascript data structure to put in the top of the page
+    # if the remote user is a manager of the comments
+    my $do_commentmanage_js = $p->{'multiform_on'};
+    if ($LJ::DISABLED{'commentmanage'}) {
+        if (ref $LJ::DISABLED{'commentmanage'} eq "CODE") {
+            $do_commentmanage_js = $LJ::DISABLED{'commentmanage'}->($remote);
+        } else {
+            $do_commentmanage_js = 0;
+        }
+    }
+
+    if ($do_commentmanage_js) {
+        my $js = "<script>\n// don't crawl this.  read http://www.livejournal.com/developer/exporting.bml\n";
+        $js .= "var LJ_cmtinfo = {\n";
+        my $canAdmin = LJ::can_manage($remote, $u) ? 1 : 0;
+        $js .= "\tjournal: '$u->{user}',\n";
+        $js .= "\tcanAdmin: $canAdmin,\n";
+        $js .= "\tremote: '$remote->{user}',\n" if $remote;
+        my $recurse = sub {
+            my ($self, $array) = @_;
+            foreach my $i (@$array) {
+                my $has_threads = scalar @{$i->{'replies'}};
+                my $poster = $i->{'poster'} ? $i->{'poster'}{'username'} : "";
+                my $child_ids = join(',', map { $_->{'talkid'} } @{$i->{'replies'}});
+                $js .= "\t$i->{'talkid'}: { rc: [$child_ids], u: '$poster' },\n";
+                $self->($self, $i->{'replies'}) if $has_threads;
+            }
+        };
+        $recurse->($recurse, $p->{'comments'});
+        chop $js; chop $js;  # remove final ",\n".  stupid javascript.
+        $js .= "\n};\n" .
+            "var LJVAR;\n".
+            "if (!LJVAR) LJVAR = new Object();\n".
+            "LJVAR.imgprefix = \"$LJ::IMGPREFIX\";\n".
+            "</script>\n";
+        $p->{'head_content'} .= $js;
+        $p->{'head_content'} .= "<script src='$LJ::SITEROOT/js/commentmanage.js'></script>\n";
+        
+    }
+
+
+    $p->{'viewing_thread'} = $get->{'thread'} ? 1 : 0;
+
+    # default values if there were no comments, because
+    # LJ::Talk::load_comments() doesn't provide them.
+    if ($copts->{'out_error'} eq 'noposts') {
+        $copts->{'out_pages'} = $copts->{'out_page'} = 1;
+        $copts->{'out_items'} = 0;
+        $copts->{'out_itemfirst'} = $copts->{'out_itemlast'} = undef;
+    }
+
+    $p->{'comment_pages'} = ItemRange({
+        'all_subitems_displayed' => ($copts->{'out_pages'} == 1),
+        'current' => $copts->{'out_page'},
+        'from_subitem' => $copts->{'out_itemfirst'},
+        'num_subitems_displayed' => scalar @comments,
+        'to_subitem' => $copts->{'out_itemlast'},
+        'total' => $copts->{'out_pages'},
+        'total_subitems' => $copts->{'out_items'},
+        '_url_of' => sub { return "$permalink?page=" . int($_[0]) .
+                               ($stylemine ? "&$stylemine" : ''); },
+    });
+
+    return $p;
+}
+
+sub EntryPage_fast_check
+{
+    my ($u, $view, $remote, $opts) = @_;
+    
+    return  unless ($view eq "entry" || $view eq "reply");
+
+    my $get = $opts->{'getargs'};
+
+    my $r = $opts->{'r'};
+    my $uri = $r->uri;
+
+    my ($ditemid, $itemid, $anum);
+    unless ($uri =~ /(\d+)\.html/) {
+        $opts->{'handler_return'} = 404;
+        return;
+    }
+
+    $ditemid = $1;
+    $anum = $ditemid % 256;
+    $itemid = $ditemid >> 8;
+
+    my $entry = LJ::Talk::get_journal_item($u, $itemid, "props_only");
+    unless ($entry && $entry->{'anum'} == $anum) {
+        $opts->{'handler_return'} = 404;
+        return;
+    }
+    my $props = $entry->{'props'};
+
+    # do they have the viewall priv?
+    my $viewall = 0;
+    my $viewsome = 0;
+    if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
+        LJ::statushistory_add($u->{'userid'}, $remote->{'userid'}, 
+                              "viewall", "entry: $u->{'user'}, itemid: $itemid, statusvis: $u->{'statusvis'}");
+        $viewall = LJ::check_priv($remote, 'canview', '*');
+        $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+    }
+
+    # check using normal rules
+    unless (LJ::can_view($remote, $entry) || $viewall) {
+        $opts->{'handler_return'} = 403;
+        return;
+    }
+
+    my $pu = $u;
+    if ($entry->{'posterid'} != $entry->{'ownerid'}) {
+        $pu = LJ::load_userid($entry->{'posterid'});
+    }
+    if (($pu && $pu->{'statusvis'} eq 'S') && !$viewsome) {
+        $opts->{'suspendeduser'} = 1;
+        return;
+    }
+
+    # check If-Modified-Since
+    my $lastmod = $props->{'commentalter'};
+    my $revisiontime = $props->{' revtime'};
+    $lastmod = $revisiontime  if $revisiontime && $revisiontime > $lastmod;
+
+    my $ims = $r->header_in('If-Modified-Since');
+    if ($ims) {
+        my $theirtime = LJ::http_to_time($ims);
+        if ($theirtime >= $lastmod && !$remote) {
+            # only for anonymous: logged users will be checked by Etag for exact match
+            # reply special: uniq challange string for regular users
+            if ($view eq "entry" || ($view eq "reply" && $r->header_in('User-Agent') =~ /$LJ::ROBOTS_REGEXP/)) {
+
+                $opts->{'notmodified'} = 1;
+                return;
+            }
+        }
+    }
+    $r->header_out("Last-Modified", LJ::time_to_http($lastmod));
+}
+
+sub EntryPage_entry
+{
+    my ($u, $remote, $opts) = @_;
+
+   ### NB!  EntryPage_fast_check was previously called, so all checks passed.
+
+    my $get = $opts->{'getargs'};
+
+    my $r = $opts->{'r'};
+    my $uri = $r->uri;
+
+    my ($ditemid, $itemid, $anum);
+    unless ($uri =~ /(\d+)\.html/) {
+        $opts->{'handler_return'} = 404;
+        return;
+    }
+
+    $ditemid = $1;
+    $anum = $ditemid % 256;
+    $itemid = $ditemid >> 8;
+
+    my $entry = LJ::Talk::get_journal_item($u, $itemid);
+    unless ($entry && $entry->{'anum'} == $anum) {
+        $opts->{'handler_return'} = 404;
+        return;
+    }
+    ### more checks skipped ###
+
+    my $props = $entry->{'props'};
+
+    my $userlite_journal = UserLite($u);
+    my $userlite_poster = $userlite_journal;
+    my $pu = $u;
+    if ($entry->{'posterid'} != $entry->{'ownerid'}) {
+        $pu = LJ::load_userid($entry->{'posterid'});
+        $userlite_poster = UserLite($pu);
+    }
+
+    my $replycount = $props->{'replycount'};
+    my $nc = "";
+    $nc .= "nc=$replycount" if $replycount; # && $remote && $remote->{'opt_nctalklinks'};
+
+    my $stylemine = $get->{'style'} eq "mine" ? "style=mine" : "";
+
+    my $userpic = Image_userpic($pu, 0, $props->{'picture_keyword'});
+
+    my $permalink = LJ::journal_base($u) . "/$ditemid.html";
+    my $readurl = LJ::Talk::talkargs($permalink, $nc, $stylemine);
+    my $posturl = LJ::Talk::talkargs($permalink, "mode=reply", $stylemine);
+
+    my $comments = CommentInfo({
+        'read_url' => $readurl,
+        'post_url' => $posturl,
+        'count' => $replycount,
+        'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
+        'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! 
+                      $props->{'opt_nocomments'}) ? 1 : 0,
+        'screened' => ($props->{'hasscreened'} && $remote &&
+                       LJ::can_manage($remote, $u)) ? 1 : 0,
+    });
+
+    # format it
+    if ($opts->{'getargs'}->{'nohtml'}) {
+        # quote all non-LJ tags
+        $entry->{'subject'} =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+        $entry->{'event'}   =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+    }
+    my $raw_subj = $entry->{'subject'};
+    LJ::CleanHTML::clean_subject(\$entry->{'subject'});
+    LJ::CleanHTML::clean_event(\$entry->{'event'}, $props->{'opt_preformatted'});
+    LJ::expand_embedded($u, $ditemid, $remote, \$entry->{'event'});
+
+    my $s2entry = Entry($u, {
+        '_rawsubject' => $raw_subj,
+        'subject' => $entry->{'subject'},
+        'text' => $entry->{'event'},
+        'dateparts' => $entry->{'alldatepart'},
+        'security' => $entry->{'security'},
+        'props' => $props,
+        'itemid' => $ditemid,
+        'comments' => $comments,
+        'journal' => $userlite_journal,
+        'poster' => $userlite_poster,
+        'new_day' => 0,
+        'end_day' => 0,
+        'userpic' => $userpic,
+        'permalink_url' => $permalink,
+        'enable_tags_compatibility' => [$opts->{enable_tags_compatibility}, $opts->{ctx}],
+    });
+    
+    return ($entry, $s2entry);
+}
+
+1;

local/cgi-bin/LJ/S2/FriendsPage.pm

@@ -0,0 +1,444 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+eval "use LJR::Distributed;";
+my $ljr = $@ ? 0 : 1;
+
+if ($ljr) {
+  use LJR::Distributed;
+}
+
+sub FriendsPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "FriendsPage";
+    $p->{'view'} = "friends";
+    $p->{'entries'} = [];
+    $p->{'friends'} = {};
+    $p->{'friends_title'} = LJ::ehtml($u->{'friendspagetitle'});
+    $p->{'filter_active'} = 0;
+    $p->{'filter_name'} = "";
+
+    my $sth;
+    my $user = $u->{'user'};
+
+    # see how often the remote user can reload this page.  
+    # "friendsviewupdate" time determines what granularity time
+    # increments by for checking for new updates
+    my $nowtime = time();
+
+    # update delay specified by "friendsviewupdate"
+    my $newinterval = LJ::get_cap_min($remote, "friendsviewupdate") || 1;
+
+    # when are we going to say page was last modified?  back up to the 
+    # most recent time in the past where $time % $interval == 0
+    my $lastmod = $nowtime;
+    $lastmod -= $lastmod % $newinterval;
+
+    # see if they have a previously cached copy of this page they
+    # might be able to still use.
+    my $ims = $opts->{'r'}->header_in('If-Modified-Since');
+    if ($ims) {
+        my $theirtime = LJ::http_to_time($ims);
+
+        # send back a 304 Not Modified if they say they've reloaded this 
+        # document in the last $newinterval seconds:
+        unless ($theirtime < $lastmod) {
+            $opts->{'handler_return'} = 304;
+            return 1;
+        }
+    }
+    $opts->{'r'}->header_out('Last-Modified', LJ::time_to_http($lastmod));
+
+    my $get = $opts->{'getargs'};
+
+    my $ret;
+
+    if ($get->{'mode'} eq "live") {
+        $ret .= "<html><head><title>${user}'s friends: live!</title></head>\n";
+        $ret .= "<frameset rows=\"100%,0%\" border=0>\n";
+        $ret .= "  <frame name=livetop src=\"friends?mode=framed\">\n";
+        $ret .= "  <frame name=livebottom src=\"friends?mode=livecond&amp;lastitemid=0\">\n";
+        $ret .= "</frameset></html>\n";
+        return $ret;
+    }
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) . "/friends";
+        return 1;
+    }
+
+    LJ::load_user_props($remote, "opt_nctalklinks", "opt_stylemine", "opt_imagelinks", "opt_ljcut_disable_friends");
+
+    # load options for image links
+    my ($maximgwidth, $maximgheight) = (undef, undef);
+    ($maximgwidth, $maximgheight) = ($1, $2)
+        if ($remote && $remote->{'userid'} == $u->{'userid'} &&
+            $remote->{'opt_imagelinks'} =~ m/^(\d+)\|(\d+)$/);
+
+    ## never have spiders index friends pages (change too much, and some 
+    ## people might not want to be indexed)
+    $p->{'head_content'} .= LJ::robot_meta_tags();
+
+    my $itemshow = S2::get_property_value($opts->{'ctx'}, "page_friends_items")+0;
+    if ($itemshow < 1) { $itemshow = 20; }
+    elsif ($itemshow > 50) { $itemshow = 50; }
+    
+    my $skip = $get->{'skip'}+0;
+    my $maxskip = ($LJ::MAX_SCROLLBACK_FRIENDS || 1000) - $itemshow;
+    if ($skip > $maxskip) { $skip = $maxskip; }
+    if ($skip < 0) { $skip = 0; }
+    my $itemload = $itemshow+$skip;
+
+    my $dayskip = $get->{'dayskip'}+0;
+
+    my $filter;
+    my $group;
+    my $common_filter = 1;
+
+    if (defined $get->{'filter'} && $remote && $remote->{'user'} eq $user) {
+        $filter = $get->{'filter'}; 
+        $common_filter = 0;
+        $p->{'filter_active'} = 1;
+        $p->{'filter_name'} = "";
+    } else {
+        if ($opts->{'pathextra'}) {
+            $group = $opts->{'pathextra'};
+            $group =~ s!^/!!;
+            $group =~ s!/$!!;
+            if ($group) { $group = LJ::durl($group); $common_filter = 0; }
+        }
+        if ($group) {
+            $p->{'filter_active'} = 1;
+            $p->{'filter_name'} = LJ::ehtml($group);
+        }
+        my $grp = LJ::get_friend_group($u, { 'name' => $group || "Default View" });
+        my $bit = $grp->{'groupnum'};
+        my $public = $grp->{'is_public'};
+        if ($bit && ($public || ($remote && $remote->{'user'} eq $user))) { 
+            $filter = (1 << $bit);
+        } elsif ($group) {
+            $opts->{'badfriendgroup'} = 1;
+            return 1;
+        }
+    }
+    
+    if ($opts->{'view'} eq "friendsfriends") {
+        $p->{'friends_mode'} = "friendsfriends";
+    }
+
+    if ($get->{'mode'} eq "livecond") 
+    {
+        ## load the itemids
+        my @items = LJ::get_friend_items({
+            'u' => $u,
+            'remote' => $remote,
+            'itemshow' => 1,
+            'skip' => 0,
+            'filter' => $filter,
+            'common_filter' => $common_filter,
+        });
+        my $first = @items ? $items[0]->{'itemid'} : 0;
+
+        $ret .= "time = " . scalar(time()) . "<br />";
+        $opts->{'headers'}->{'Refresh'} = "30;URL=$LJ::SITEROOT/users/$user/friends?mode=livecond&lastitemid=$first";
+        if ($get->{'lastitemid'} == $first) {
+            $ret .= "nothing new!";
+        } else {
+            if ($get->{'lastitemid'}) {
+                $ret .= "<b>New stuff!</b>\n";
+                $ret .= "<script language=\"JavaScript\">\n";
+                $ret .= "window.parent.livetop.location.reload(true);\n";     
+                $ret .= "</script>\n";
+                $opts->{'trusted_html'} = 1;
+            } else {
+                $ret .= "Friends Live! started.";
+            }
+        }
+        return $ret;
+    }
+    
+    ## load the itemids 
+    my %friends;
+    my %friends_row;
+    my @items = LJ::get_friend_items({
+        'u' => $u,
+        'remote' => $remote,
+        'itemshow' => $itemshow,
+        'skip' => $skip,
+        'dayskip' => $dayskip,
+        'filter' => $filter,
+        'common_filter' => $common_filter,
+        'friends_u' => \%friends,
+        'friends' => \%friends_row,
+        'showtypes' => $get->{'show'},
+        'friendsoffriends' => $opts->{'view'} eq "friendsfriends",
+        'dateformat' => 'S2',
+    });
+
+    while ($_ = each %friends) {
+        # we expect fgcolor/bgcolor to be in here later
+        $friends{$_}->{'fgcolor'} = $friends_row{$_}->{'fgcolor'} || '#ffffff';
+        $friends{$_}->{'bgcolor'} = $friends_row{$_}->{'bgcolor'} || '#000000';
+    }
+
+    return $p unless %friends;
+
+    my %posters;
+    {
+        my @posterids;
+        foreach my $item (@items) {
+            next if $friends{$item->{'posterid'}};
+            push @posterids, $item->{'posterid'};
+        }
+        LJ::load_userids_multiple([ map { $_ => \$posters{$_} } @posterids ])
+            if @posterids;
+    }
+
+    my %objs_of_picid;
+    my @userpic_load;
+    
+    my %lite;   # posterid -> s2_UserLite
+    my $get_lite = sub {
+        my $id = shift;
+        return $lite{$id} if $lite{$id};
+        return $lite{$id} = UserLite($posters{$id} || $friends{$id});
+    };
+    
+    my $eventnum = 0;
+    my $hiddenentries = 0;
+  ENTRY:
+    foreach my $item (@items) 
+    {
+        my ($friendid, $posterid, $itemid, $security, $alldatepart) = 
+            map { $item->{$_} } qw(ownerid posterid itemid security alldatepart);
+
+        my $fru = $friends{$friendid};
+        my ($friend, $poster);
+        $friend = $poster = $fru->{'user'};
+        $p->{'friends'}->{$fru->{'user'}} ||= Friend($fru);
+
+        my $clusterid = $item->{'clusterid'}+0;
+
+        my $props = $item->{'props'};
+
+        my $replycount = $props->{'replycount'};    
+        my $subject = $item->{'text'}->[0];
+        my $text    = $item->{'text'}->[1];
+        if ($get->{'nohtml'}) {
+            # quote all non-LJ tags
+            $subject =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+            $text    =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+        }
+
+        LJ::CleanHTML::clean_subject(\$subject) if $subject;
+
+        my $ditemid = $itemid * 256 + $item->{'anum'};
+
+        my $stylemine = "";
+        $stylemine .= "style=mine" if $remote && $remote->{'opt_stylemine'} &&
+                                      $remote->{'userid'} != $friendid;
+
+        LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $props->{'opt_preformatted'},
+                                             'cuturl' => LJ::item_link($fru, $itemid, $item->{'anum'}, $stylemine), 
+                                             'maximgwidth' => $maximgwidth,
+                                             'maximgheight' => $maximgheight,
+               'ljcut_disable' => $remote->{'opt_ljcut_disable_friends'}, });
+        LJ::expand_embedded($fru, $ditemid, $remote, \$text);
+
+        my $userlite_poster = $get_lite->($posterid);
+        my $userlite_journal = $get_lite->($friendid);
+
+        # get the poster user
+        my $po = $posters{$posterid} || $friends{$posterid};  
+
+        # don't allow posts from suspended users
+        if ($po->{'statusvis'} eq 'S') {
+            $hiddenentries++; # Remember how many we've skipped for later
+            next ENTRY;
+        }
+
+        # do the picture
+        my $picid = 0;
+        my $picu = undef;
+        if ($friendid != $posterid && S2::get_property_value($opts->{ctx}, 'use_shared_pic')) {
+            # using the community, the user wants to see shared pictures
+            $picu = $fru;
+
+            # use shared pic for community
+            $picid = $fru->{defaultpicid};
+        } else {
+            # we're using the poster for this picture
+            $picu = $po;
+
+            # check if they specified one
+            $picid = LJ::get_picid_from_keyword($po, $props->{picture_keyword})
+                if $props->{picture_keyword};
+            
+            # fall back on the poster's default
+            $picid ||= $po->{defaultpicid};
+        }
+
+        my $nc = "";
+        $nc .= "nc=$replycount" if $replycount; # && $remote && $remote->{'opt_nctalklinks'};
+
+        my $journalbase = LJ::journal_base($fru);
+        my $permalink = "$journalbase/$ditemid.html";
+        my $readurl = LJ::Talk::talkargs($permalink, $nc, $stylemine);
+        my $posturl = LJ::Talk::talkargs($permalink, "mode=reply", $stylemine);
+        my $synurl = "";
+
+        if ($ljr && $props->{'syn_link'}) {
+          my $rs = LJR::Distributed::match_remote_server($props->{'syn_link'});
+          if ($rs->{"servertype"} eq "lj") {
+            $readurl = $props->{'syn_link'};
+            $posturl = $props->{'syn_link'} . "?mode=reply";
+            $replycount = 'Read';
+          }
+          else {
+            $posturl = $props->{'syn_link'};
+            $replycount = undef;
+          }
+          $synurl = $props->{'syn_link'};
+        }
+
+        my $comments = CommentInfo({
+            'read_url' => $readurl,
+            'post_url' => $posturl,
+            'syn_url'  => $synurl,
+            'count' => $replycount,
+            'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
+            'enabled' => ($fru->{'opt_showtalklinks'} eq "Y" &&
+                          ! $props->{'opt_nocomments'} ||
+                          $props->{'syn_link'}
+                          ) ? 1 : 0,
+            'screened' => ($remote && LJ::can_manage($remote, $fru) && $props->{'hasscreened'}) ? 1 : 0,
+        });
+
+        my $moodthemeid = $u->{'opt_forcemoodtheme'} eq 'Y' ?
+            $u->{'moodthemeid'} : $fru->{'moodthemeid'};
+
+        my $entry = Entry($u, {
+            'subject' => $subject,
+            'text' => $text,
+            'dateparts' => $alldatepart,
+            'security' => $security,
+            'props' => $props,
+            'itemid' => $ditemid,
+            'journal' => $userlite_journal,
+            'poster' => $userlite_poster,
+            'comments' => $comments,
+            'new_day' => 0,  # setup below
+            'end_day' => 0,  # setup below
+            'userpic' => undef,
+            'permalink_url' => $permalink,
+            'base_url' => $journalbase,
+            'moodthemeid' => $moodthemeid,
+            'enable_tags_compatibility' => [$opts->{enable_tags_compatibility}, $opts->{ctx}],
+        });
+        $entry->{'_ymd'} = join('-', map { $entry->{'time'}->{$_} } qw(year month day));
+
+        if ($picid && $picu) {
+            push @userpic_load, [ $picu, $picid ];
+            push @{$objs_of_picid{$picid}}, \$entry->{'userpic'};
+        }
+
+        push @{$p->{'entries'}}, $entry;
+        $eventnum++;
+        
+    } # end while
+
+    # set the new_day and end_day members.
+    if ($eventnum) {
+        for (my $i = 0; $i < $eventnum; $i++) {
+            my $entry = $p->{'entries'}->[$i];
+            $entry->{'new_day'} = 1;
+            my $last = $i;
+            for (my $j = $i+1; $j < $eventnum; $j++) {
+                my $ej = $p->{'entries'}->[$j];
+                if ($ej->{'_ymd'} eq $entry->{'_ymd'}) {
+                    $last = $j;
+                }
+            }
+            $p->{'entries'}->[$last]->{'end_day'} = 1;
+            $i = $last;
+        }
+    }
+
+    # load the pictures that were referenced, then retroactively populate
+    # the userpic fields of the Entries above
+    my %userpics;
+    LJ::load_userpics(\%userpics, \@userpic_load);
+
+    foreach my $picid (keys %userpics) {
+        my $up = Image("$LJ::USERPIC_ROOT/$picid/$userpics{$picid}->{'userid'}",
+                       $userpics{$picid}->{'width'},
+                       $userpics{$picid}->{'height'});
+        foreach (@{$objs_of_picid{$picid}}) { $$_ = $up; }
+    }
+
+    # make the skip links
+    my $nav = {
+        '_type' => 'RecentNav',
+        'version' => 1,
+        'skip' => $skip,
+        'count' => $eventnum,
+    };
+
+    my $base = "$u->{'_journalbase'}/$opts->{'view'}";
+    if ($group) {
+        $base .= "/" . LJ::eurl($group);
+    }
+
+    # $linkfilter is distinct from $filter: if user has a default view,
+    # $filter is now set according to it but we don't want it to show in the links.
+    # $incfilter may be true even if $filter is 0: user may use filter=0 to turn
+    # off the default group
+    my $linkfilter = $get->{'filter'} + 0;
+    my $incfilter = defined $get->{'filter'};
+
+    # if we've skipped down, then we can skip back up
+    if ($skip) {
+        my %linkvars;
+        $linkvars{'filter'} = $linkfilter if $incfilter;
+        $linkvars{'show'} = $get->{'show'} if $get->{'show'} =~ /^\w+$/;
+        my $newskip = $skip - $itemshow;
+        if ($newskip > 0) { $linkvars{'skip'} = $newskip; }
+        else { $newskip = 0; }
+        $linkvars{'dayskip'} = $dayskip if $dayskip;
+        $nav->{'forward_url'} = LJ::make_link($base, \%linkvars);
+        $nav->{'forward_skip'} = $newskip;
+        $nav->{'forward_count'} = $itemshow;
+    }
+
+    ## unless we didn't even load as many as we were expecting on this
+    ## page, then there are more (unless there are exactly the number shown 
+    ## on the page, but who cares about that)
+    # Must remember to count $hiddenentries or we'll have no skiplinks when > 1
+    unless (($eventnum + $hiddenentries) != $itemshow || $skip == $maxskip) {
+        my %linkvars;
+        $linkvars{'filter'} = $linkfilter if $incfilter;
+        $linkvars{'show'} = $get->{'show'} if $get->{'show'} =~ /^\w+$/;
+        my $newskip = $skip + $itemshow;
+        $linkvars{'skip'} = $newskip;
+        $linkvars{'dayskip'} = $dayskip if $dayskip;
+        $nav->{'backward_url'} = LJ::make_link($base, \%linkvars);
+        $nav->{'backward_skip'} = $newskip;
+        $nav->{'backward_count'} = $itemshow;
+    }
+
+    $p->{'nav'} = $nav;
+
+    if ($get->{'mode'} eq "framed") {
+        $p->{'head_content'} .= "<base target='_top' />";
+    }
+
+    return $p;
+}
+
+1;

local/cgi-bin/LJ/S2/MonthPage.pm

@@ -0,0 +1,224 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+sub MonthPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $get = $opts->{'getargs'};
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "MonthPage";
+    $p->{'view'} = "month";
+    $p->{'days'} = [];
+
+    my $ctx = $opts->{'ctx'};
+
+    my $dbcr = LJ::get_cluster_reader($u);
+
+    my $user = $u->{'user'};
+    my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
+            "/" . $opts->{'pathextra'};
+        return 1;
+    }
+
+    if ($u->{'opt_blockrobots'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+
+    my ($year, $month);
+    if ($opts->{'pathextra'} =~ m!^/(\d\d\d\d)/(\d\d)\b!) {
+        ($year, $month) = ($1, $2);
+    }
+
+    $opts->{'errors'} = [];
+    if ($month < 1 || $month > 12) { push @{$opts->{'errors'}}, "Invalid month: $month"; }
+    if ($year < 1970 || $year > 2038) { push @{$opts->{'errors'}}, "Invalid year: $year"; }
+    unless ($dbcr) { push @{$opts->{'errors'}}, "Database temporarily unavailable"; }
+    return if @{$opts->{'errors'}};
+
+    $p->{'date'} = Date($year, $month, 0);
+
+    # load the log items
+    my $dateformat = "%Y %m %d %H %i %s %w"; # yyyy mm dd hh mm ss day_of_week
+    my $sth;
+
+    my $secwhere = "AND l.security='public'";
+    my $viewall = 0;
+    my $viewsome = 0;
+    if ($remote) {
+
+        # do they have the viewall priv?
+        if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
+            LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
+                                  "viewall", "month: $user, statusvis: $u->{'statusvis'}");
+            $viewall = LJ::check_priv($remote, 'canview', '*');
+            $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+        }
+
+        if ($remote->{'userid'} == $u->{'userid'} || $viewall) {
+            $secwhere = "";   # see everything
+        } elsif ($remote->{'journaltype'} eq 'P' || $remote->{'journaltype'} eq 'I') {
+            my $gmask = LJ::get_groupmask($u, $remote);
+            $secwhere = "AND (l.security='public' OR (l.security='usemask' AND l.allowmask & $gmask))"
+                if $gmask;
+        }
+    }
+
+    $sth = $dbcr->prepare("SELECT l.jitemid AS 'itemid', l.posterid, l.anum, l.day, ".
+                          "       DATE_FORMAT(l.eventtime, '$dateformat') AS 'alldatepart', ".
+                          "       l.replycount, l.security ".
+                          "FROM log2 l ".
+                          "WHERE l.journalid=? AND l.year=? AND l.month=? ".
+                          "$secwhere LIMIT 2000");
+    $sth->execute($u->{'userid'}, $year, $month);
+
+    my @items;
+    push @items, $_ while $_ = $sth->fetchrow_hashref;
+    @items = sort { $a->{'alldatepart'} cmp $b->{'alldatepart'} } @items;
+
+    LJ::fill_items_with_text_props(\@items, $u, {'only_subject' => 1});
+
+    my (%pu, %pu_lite);  # poster users; UserLite objects
+    foreach (@items) {
+        $pu{$_->{'posterid'}} = undef;
+    }
+    LJ::load_userids_multiple([map { $_, \$pu{$_} } keys %pu], [$u]);
+    $pu_lite{$_} = UserLite($pu{$_}) foreach keys %pu;
+
+    my %day_entries;  # <day> -> [ Entry+ ]
+
+    my $opt_text_subjects = S2::get_property_value($ctx, "page_month_textsubjects");
+    my $userlite_journal = UserLite($u);
+
+  ENTRY:
+    foreach my $item (@items)
+    {
+        my ($posterid, $itemid, $security, $alldatepart, $replycount, $anum) =
+            map { $item->{$_} } qw(posterid itemid security alldatepart replycount anum);
+        my $day = $item->{'day'};
+
+        # don't show posts from suspended users
+        next unless $pu{$posterid};
+        next ENTRY if $pu{$posterid}->{'statusvis'} eq 'S' && !$viewsome;
+
+        my $subject = $item->{'text'}->[0];
+        my $props = $item->{'props'};
+
+        if ($opt_text_subjects) {
+            LJ::CleanHTML::clean_subject_all(\$subject);
+        } else {
+            LJ::CleanHTML::clean_subject(\$subject);
+        }
+
+        my $ditemid = $itemid*256 + $anum;
+        my $nc = "";
+        $nc .= "nc=$replycount" if $replycount; # && $remote && $remote->{'opt_nctalklinks'};
+        my $permalink = "$journalbase/$ditemid.html";
+        my $readurl = $permalink;
+        $readurl .= "?$nc" if $nc;
+        my $posturl = $permalink . "?mode=reply";
+
+        my $comments = CommentInfo({
+            'read_url' => $readurl,
+            'post_url' => $posturl,
+            'count' => $replycount,
+            'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
+            'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $props->{'opt_nocomments'}) ? 1 : 0,
+            'screened' => ($props->{'hasscreened'} && $remote &&
+                           ($remote->{'user'} eq $u->{'user'} || LJ::can_manage($remote, $u))) ? 1 : 0,
+        });
+
+        my $userlite_poster = $userlite_journal;
+        my $userpic = $p->{'journal'}->{'default_pic'};
+        if ($u->{'userid'} != $posterid) {
+            $userlite_poster = $pu_lite{$posterid};
+            $userpic = Image_userpic($pu{$posterid}, 0, $props->{'picture_keyword'});
+        }
+
+        my $entry = Entry($u, {
+            'subject' => $subject,
+            'text' => "",
+            'dateparts' => $alldatepart,
+            'security' => $security,
+            'props' => $props,
+            'itemid' => $ditemid,
+            'journal' => $userlite_journal,
+            'poster' => $userlite_poster,
+            'comments' => $comments,
+            'userpic' => $userpic,
+            'permalink_url' => $permalink,
+        });
+
+        push @{$day_entries{$day}}, $entry;
+    }
+
+    my $days_month = LJ::days_in_month($month, $year);
+    for my $day (1..$days_month) {
+        my $entries = $day_entries{$day} || [];
+        my $month_day = {
+            '_type' => 'MonthDay',
+            'date' => Date($year, $month, $day),
+            'day' => $day,
+            'has_entries' => scalar @$entries > 0,
+            'num_entries' => scalar @$entries,
+            'url' => $journalbase . sprintf("/%04d/%02d/%02d/", $year, $month, $day),
+            'entries' => $entries,
+        };
+        push @{$p->{'days'}}, $month_day;
+    }
+
+    # populate redirector
+    my $vhost = $opts->{'vhost'};
+    $vhost =~ s/:.*//;
+    $p->{'redir'} = {
+        '_type' => "Redirector",
+        'user' => $u->{'user'},
+        'vhost' => $vhost,
+        'type' => 'monthview',
+        'url' => "$LJ::SITEROOT/go.bml",
+    };
+    
+    # figure out what months have been posted into
+    my $nowval = $year*12 + $month;
+
+    $p->{'months'} = [];
+
+    my $days = LJ::get_daycounts($u, $remote) || [];
+    my $lastmo;
+    foreach my $day (@$days) {
+        my ($oy, $om) = ($day->[0], $day->[1]);
+        my $mo = "$oy-$om";
+        next if $mo eq $lastmo;
+        $lastmo = $mo;
+
+        my $date = Date($oy, $om, 0);
+        my $url = $journalbase . sprintf("/%04d/%02d/", $oy, $om);
+        push @{$p->{'months'}}, {
+            '_type' => "MonthEntryInfo",
+            'date' => $date,
+            'url' => $url,
+            'redir_key' => sprintf("%04d%02d", $oy, $om),
+        };
+
+        my $val = $oy*12+$om;
+        if ($val < $nowval) {
+            $p->{'prev_url'} = $url;
+            $p->{'prev_date'} = $date;
+        }
+        if ($val > $nowval && ! $p->{'next_date'}) {
+            $p->{'next_url'} = $url;
+            $p->{'next_date'} = $date;
+        }
+    }
+
+    return $p;
+}
+
+1;

local/cgi-bin/LJ/S2/RecentPage.pm

@@ -0,0 +1,216 @@
+use strict;
+package LJ::S2;
+
+sub RecentPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "RecentPage";
+    $p->{'view'} = "recent";
+    $p->{'entries'} = [];
+
+    my $user = $u->{'user'};
+    my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'});
+        return;
+    }
+
+    LJ::load_user_props($remote, "opt_nctalklinks", "opt_ljcut_disable_lastn");
+
+    my $get = $opts->{'getargs'};
+
+    if ($opts->{'pathextra'}) {
+        $opts->{'badargs'} = 1;
+        return 1;
+    }
+
+    if ($u->{'opt_blockrobots'} || $get->{'skip'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+
+    $p->{'head_content'} .= qq{<link rel="openid.server" href="$LJ::OPENID_SERVER" />\n}
+        if LJ::OpenID::server_enabled();
+
+    my $itemshow = S2::get_property_value($opts->{'ctx'}, "page_recent_items")+0;
+    if ($itemshow < 1) { $itemshow = 20; }
+    elsif ($itemshow > 50) { $itemshow = 50; }
+
+    my $skip = $get->{'skip'}+0;
+    my $maxskip = $LJ::MAX_HINTS_LASTN-$itemshow;
+    if ($skip < 0) { $skip = 0; }
+    if ($skip > $maxskip) { $skip = $maxskip; }
+
+    my $dayskip = $get->{'dayskip'}+0;
+
+    # do they want to view all entries, regardless of security?
+    my $viewall = 0;
+    my $viewsome = 0;
+    if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
+        LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
+                              "viewall", "lastn: $user, statusvis: $u->{'statusvis'}");
+        $viewall = LJ::check_priv($remote, 'canview', '*');
+        $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+    }
+
+    ## load the items
+    my $err;
+    my @items = LJ::get_recent_items({
+        'u' => $u,
+        'clustersource' => 'slave',
+        'viewall' => $viewall,
+        'remote' => $remote,
+        'itemshow' => $itemshow,
+        'skip' => $skip,
+        'dayskip' => $dayskip,
+        'tags' => $opts->{tags},
+        'dateformat' => 'S2',
+        'order' => ($u->{'journaltype'} eq "C" || $u->{'journaltype'} eq "Y")  # community or syndicated
+            ? "logtime" : "",
+        'err' => \$err,
+    });
+
+    die $err if $err;
+
+    my $lastdate = "";
+    my $itemnum = 0;
+    my $lastentry = undef;
+
+    my (%apu, %apu_lite);  # alt poster users; UserLite objects
+    foreach (@items) {
+        next unless $_->{'posterid'} != $u->{'userid'};
+        $apu{$_->{'posterid'}} = undef;
+    }
+    if (%apu) {
+        LJ::load_userids_multiple([map { $_, \$apu{$_} } keys %apu], [$u]);
+        $apu_lite{$_} = UserLite($apu{$_}) foreach keys %apu;
+    }
+
+    my $userlite_journal = UserLite($u);
+
+  ENTRY:
+    foreach my $item (@items)
+    {
+        my ($posterid, $itemid, $security, $alldatepart) =
+            map { $item->{$_} } qw(posterid itemid security alldatepart);
+
+        my $props = $item->{'props'};
+
+        my $replycount = $props->{'replycount'};
+        my $subject = $item->{'text'}->[0];
+        my $text    = $item->{'text'}->[1];
+        if ($get->{'nohtml'}) {
+            # quote all non-LJ tags
+            $subject =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+            $text    =~ s{<(?!/?lj)(.*?)>} {&lt;$1&gt;}gi;
+        }
+
+        # don't show posts from suspended users unless the user doing the viewing says to (and is allowed)
+        next ENTRY if $apu{$posterid} && $apu{$posterid}->{'statusvis'} eq 'S' && !$viewsome;
+
+        my $date = substr($alldatepart, 0, 10);
+        my $new_day = 0;
+        if ($date ne $lastdate) {
+            $new_day = 1;
+            $lastdate = $date;
+            $lastentry->{'end_day'} = 1 if $lastentry;
+        }
+
+        $itemnum++;
+        LJ::CleanHTML::clean_subject(\$subject) if $subject;
+
+        my $ditemid = $itemid * 256 + $item->{'anum'};
+        LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $props->{'opt_preformatted'},
+                                              'cuturl' => LJ::item_link($u, $itemid, $item->{'anum'}),
+                                              'ljcut_disable' => $remote->{"opt_ljcut_disable_lastn"}, });
+        LJ::expand_embedded($u, $ditemid, $remote, \$text);
+
+        my $nc = "";
+        $nc .= "nc=$replycount" if $replycount; # && $remote && $remote->{'opt_nctalklinks'};
+
+        my $permalink = "$journalbase/$ditemid.html";
+        my $readurl = $permalink;
+        $readurl .= "?$nc" if $nc;
+        my $posturl = $permalink . "?mode=reply";
+
+        my $comments = CommentInfo({
+            'read_url' => $readurl,
+            'post_url' => $posturl,
+            'count' => $replycount,
+            'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
+            'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $props->{'opt_nocomments'}) ? 1 : 0,
+            'screened' => ($props->{'hasscreened'} && ($remote->{'user'} eq $u->{'user'}|| LJ::can_manage($remote, $u))) ? 1 : 0,
+        });
+
+        my $userlite_poster = $userlite_journal;
+        my $pu = $u;
+        if ($u->{'userid'} != $posterid) {
+            $userlite_poster = $apu_lite{$posterid} or die "No apu_lite for posterid=$posterid";
+            $pu = $apu{$posterid};
+        }
+        my $userpic = Image_userpic($pu, 0, $props->{'picture_keyword'});
+
+        my $entry = $lastentry = Entry($u, {
+            'subject' => $subject,
+            'text' => $text,
+            'dateparts' => $alldatepart,
+            'security' => $security,
+            'props' => $props,
+            'itemid' => $ditemid,
+            'journal' => $userlite_journal,
+            'poster' => $userlite_poster,
+            'comments' => $comments,
+            'new_day' => $new_day,
+            'end_day' => 0,   # if true, set later
+            'userpic' => $userpic,
+            'permalink_url' => $permalink,
+            'enable_tags_compatibility' => [$opts->{enable_tags_compatibility}, $opts->{ctx}],
+        });
+
+        push @{$p->{'entries'}}, $entry;
+
+    } # end huge while loop
+
+    # mark last entry as closing.
+    $p->{'entries'}->[-1]->{'end_day'} = 1 if $itemnum;
+
+    #### make the skip links
+    my $nav = {
+        '_type' => 'RecentNav',
+        'version' => 1,
+        'skip' => $skip,
+        'count' => $itemnum,
+    };
+
+    # if we've skipped down, then we can skip back up
+    if ($skip) {
+        my $newskip = $skip - $itemshow;
+        $newskip = 0 if $newskip <= 0;
+        $nav->{'forward_skip'} = $newskip;
+        $nav->{'forward_url'} = LJ::make_link("$p->{base_url}/", { skip => ($newskip || ""), tag => (LJ::eurl($get->{tag}) || ""), dayskip => ($dayskip || "") });
+        $nav->{'forward_count'} = $itemshow;
+    }
+
+    # unless we didn't even load as many as we were expecting on this
+    # page, then there are more (unless there are exactly the number shown
+    # on the page, but who cares about that)
+    unless ($itemnum != $itemshow) {
+        $nav->{'backward_count'} = $itemshow;
+        if ($skip == $maxskip) {
+            my $date_slashes = $lastdate;  # "yyyy mm dd";
+            $date_slashes =~ s! !/!g;
+            $nav->{'backward_url'} = "$p->{'base_url'}/day/$date_slashes";
+        } else {
+            my $newskip = $skip + $itemshow;
+            $nav->{'backward_url'} = LJ::make_link("$p->{'base_url'}/", { skip => ($newskip || ""), tag => (LJ::eurl($get->{tag}) || ""), dayskip => ($dayskip || "") });
+            $nav->{'backward_skip'} = $newskip;
+        }
+    }
+
+    $p->{'nav'} = $nav;
+    return $p;
+}
+
+1;

local/cgi-bin/LJ/S2/ReplyPage.pm

@@ -0,0 +1,139 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+sub ReplyPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "ReplyPage";
+    $p->{'view'} = "reply";
+
+    my $get = $opts->{'getargs'};
+
+    my ($entry, $s2entry) = EntryPage_entry($u, $remote, $opts);
+    return if $opts->{'suspendeduser'};
+    return if $opts->{'handler_return'};
+    my $ditemid = $entry->{'itemid'}*256 + $entry->{'anum'};
+    $p->{'head_content'} .= $LJ::COMMON_CODE{'chalresp_js'};
+
+    if ($u->{'opt_blockrobots'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+
+    $p->{'entry'} = $s2entry;
+
+    # setup the replying item
+    my $replyto = $s2entry;
+    my $parpost;
+    if ($get->{'replyto'}) {
+        my $re_talkid = int($get->{'replyto'} >> 8);
+        my $re_anum = $get->{'replyto'} % 256;
+        unless ($re_anum == $entry->{'anum'}) {
+            $opts->{'handler_return'} = 404;
+            return;
+        }
+
+        my $sql = "SELECT jtalkid, posterid, state, datepost FROM talk2 ".
+            "WHERE journalid=$u->{'userid'} AND jtalkid=$re_talkid ".
+            "AND nodetype='L' AND nodeid=$entry->{'jitemid'}";
+        foreach my $pass (1, 2) {
+            my $db = $pass == 1 ? LJ::get_cluster_reader($u) : LJ::get_cluster_def_reader($u);
+            $parpost = $db->selectrow_hashref($sql);
+            last if $parpost;
+        }
+        unless ($parpost and $parpost->{'state'} ne 'D') {
+            $opts->{'handler_return'} = 404;
+            return;
+        }
+        if ($parpost->{'state'} eq 'S' && !LJ::Talk::can_unscreen($remote, $u, $s2entry->{'poster'}->{'username'}, undef)) {
+            $opts->{'handler_return'} = 403;
+            return;
+        }
+        if ($parpost->{'state'} eq 'F') {
+            # frozen comment, no replies allowed
+            
+            # FIXME: eventually have S2 ErrorPage to handle this and similar
+            #    For now, this hack will work; this error is pretty uncommon anyway.
+            $opts->{status} = "403 Forbidden";
+            return "<p>This thread has been frozen; no more replies are allowed.</p>";
+        }
+
+        my $tt = LJ::get_talktext2($u, $re_talkid);
+        $parpost->{'subject'} = $tt->{$re_talkid}->[0];
+        $parpost->{'body'} = $tt->{$re_talkid}->[1];
+        $parpost->{'props'} =
+            LJ::load_talk_props2($u, [ $re_talkid ])->{$re_talkid} || {};
+
+        if($LJ::UNICODE && $parpost->{'props'}->{'unknown8bit'}) {
+            LJ::item_toutf8($u, \$parpost->{'subject'}, \$parpost->{'body'}, {});
+        }
+
+        LJ::CleanHTML::clean_comment(\$parpost->{'body'}, 
+                                     { 'preformatted' => $parpost->{'props'}->{'opt_preformatted'}, 
+                                       'anon_comment' => !$parpost->{posterid} });
+        
+        my $datetime = DateTime_unix(LJ::mysqldate_to_time($parpost->{'datepost'}));
+
+        my ($s2poster, $pu);
+        my $comment_userpic;
+        if ($parpost->{'posterid'}) {
+            $pu = LJ::load_userid($parpost->{'posterid'});
+            return $opts->{handler_return} = 403 if $pu->{statusvis} eq 'S'; # do not show comments by suspended users
+            $s2poster = UserLite($pu);
+
+            # FIXME: this is a little heavy:
+            $comment_userpic = Image_userpic($pu, 0, $parpost->{'props'}->{'picture_keyword'});
+        }
+        
+        my $dtalkid = $re_talkid * 256 + $entry->{'anum'};
+        $replyto = {
+            '_type' => 'EntryLite',
+            'subject' => LJ::ehtml($parpost->{'subject'}),
+            'text' => $parpost->{'body'},
+            'userpic' => $comment_userpic,
+            'poster' => $s2poster,
+            'journal' => $s2entry->{'journal'},
+            'metadata' => {},
+            'permalink_url' => $u->{'_journalbase'} . "/$ditemid.html?view=$dtalkid#t$dtalkid",
+            'depth' => 1,
+            'time' => $datetime,
+        };
+    }
+
+    $p->{'replyto'} = $replyto;
+
+    $p->{'form'} = {
+        '_type' => "ReplyForm",
+        '_remote' => $remote,
+        '_u' => $u,
+        '_ditemid' => $ditemid,
+        '_parpost' => $parpost,
+    };
+
+    return $p;
+}
+
+package S2::Builtin::LJ;
+
+sub ReplyForm__print
+{
+    my ($ctx, $form) = @_;
+    my $remote = $form->{'_remote'};
+    my $u = $form->{'_u'};
+    my $parpost = $form->{'_parpost'};
+    my $parent = $parpost ? $parpost->{'jtalkid'} : 0;
+
+    $S2::pout->(LJ::Talk::talkform({ 'remote'   => $remote,
+                                     'journalu' => $u,
+                                     'parpost'  => $parpost,
+                                     'replyto'  => $parent,
+                                     'ditemid'  => $form->{'_ditemid'},
+                                     'form'     => $form }));
+
+}
+
+1;

local/cgi-bin/LJ/S2/YearPage.pm

@@ -0,0 +1,181 @@
+#!/usr/bin/perl
+#
+
+use strict;
+package LJ::S2;
+
+sub YearPage
+{
+    my ($u, $remote, $opts) = @_;
+
+    my $p = Page($u, $opts);
+    $p->{'_type'} = "YearPage";
+    $p->{'view'} = "archive";
+
+    my $user = $u->{'user'};
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
+            "/calendar" . $opts->{'pathextra'};
+        return 1;
+    }
+
+    if ($u->{'opt_blockrobots'}) {
+        $p->{'head_content'} .= LJ::robot_meta_tags();
+    }
+    if ($LJ::UNICODE) {
+        $p->{'head_content'} .= '<meta http-equiv="Content-Type" content="text/html; charset='.$opts->{'saycharset'}."\" />\n";
+    }
+
+    my $get = $opts->{'getargs'};
+
+    my $count = LJ::S2::get_journal_day_counts($p);
+    my @years = sort { $a <=> $b } keys %$count;
+    my $maxyear = @years ? $years[-1] : undef;
+    my $year = $get->{'year'};  # old form was /users/<user>/calendar?year=1999
+
+    # but the new form is purtier:  */calendar/2001
+    if (! $year && $opts->{'pathextra'} =~ m!^/(\d\d\d\d)/?\b!) {
+        $year = $1;
+    }
+
+    # else... default to the year they last posted.
+    $year ||= $maxyear;  
+
+    $p->{'year'} = $year;
+    $p->{'years'} = [];
+    foreach (@years) {
+        push @{$p->{'years'}}, YearYear($_, "$p->{'base_url'}/$_/", $_ == $p->{'year'});
+    }
+
+    $p->{'months'} = [];
+
+    for my $month (1..12) {
+        push @{$p->{'months'}}, YearMonth($p, {
+            'month' => $month,
+            'year' => $year,
+        });
+    }
+
+    return $p;
+}
+
+sub YearMonth {
+    my ($p, $calmon) = @_;
+
+    my ($month, $year) = ($calmon->{'month'}, $calmon->{'year'});
+    $calmon->{'_type'} = 'YearMonth';
+    $calmon->{'weeks'} = [];
+    $calmon->{'url'} = sprintf("$p->{'_u'}->{'_journalbase'}/$year/%02d/", $month);
+
+    my $count = LJ::S2::get_journal_day_counts($p);
+    my $has_entries = $count->{$year} && $count->{$year}->{$month} ? 1 : 0;
+    $calmon->{'has_entries'} = $has_entries;
+
+    my $start_monday = 0;  # FIXME: check some property to see if weeks start on monday
+    my $week = undef;
+
+    my $flush_week = sub {
+        my $end_month = shift;
+        return unless $week;
+        push @{$calmon->{'weeks'}}, $week;
+        if ($end_month) {
+            $week->{'post_empty'} = 
+                7 - $week->{'pre_empty'} - @{$week->{'days'}};
+        }
+        $week = undef;
+    };
+
+    my $push_day = sub {
+        my $d = shift;
+        unless ($week) {
+            my $leading = $d->{'date'}->{'_dayofweek'}-1;
+            if ($start_monday) {
+                $leading = 6 if --$leading < 0;
+            }
+            $week = {
+                '_type' => 'YearWeek',
+                'days' => [],
+                'pre_empty' => $leading,
+                'post_empty' => 0,
+            };
+        }
+        push @{$week->{'days'}}, $d;
+        if ($week->{'pre_empty'} + @{$week->{'days'}} == 7) {
+            $flush_week->();
+            my $size = scalar @{$calmon->{'weeks'}};
+        }
+    };
+
+    my $day_of_week = LJ::day_of_week($year, $month, 1);
+
+    my $daysinmonth = LJ::days_in_month($month, $year);
+
+    for my $day (1..$daysinmonth) {
+        # so we don't auto-vivify years/months
+        my $daycount = $has_entries ? $count->{$year}->{$month}->{$day} : 0;
+        my $d = YearDay($p->{'_u'}, $year, $month, $day, 
+                        $daycount, $day_of_week+1);
+        $push_day->($d);
+        $day_of_week = ($day_of_week + 1) % 7;
+    }
+    $flush_week->(1); # end of month flag
+
+    my $nowval = $year * 12 + $month;
+
+    # determine the most recent month with posts that is older than
+    # the current time $month/$year.  gives calendars the ability to
+    # provide smart next/previous links.
+    my $maxbefore;
+    while (my ($iy, $h) = each %$count) {
+        next if $iy > $year;
+        while (my $im = each %$h) {
+            next if $im >= $month;
+            my $val = $iy * 12 + $im;
+            if ($val < $nowval && $val > $maxbefore) {
+                $maxbefore = $val;
+                $calmon->{'prev_url'} = $p->{'_u'}->{'_journalbase'} . sprintf("/%04d/%02d/", $iy, $im);
+                $calmon->{'prev_date'} = Date($iy, $im, 0);
+            }
+        }
+    }
+
+    # same, except inverse: next month after current time with posts
+    my $minafter;
+    while (my ($iy, $h) = each %$count) {
+        next if $iy < $year;
+        while (my $im = each %$h) {
+            next if $im <= $month;
+            my $val = $iy * 12 + $im;
+            if ($val > $nowval && (!$minafter || $val < $minafter)) {
+                $minafter = $val;
+                $calmon->{'next_url'} = $p->{'_u'}->{'_journalbase'} . sprintf("/%04d/%02d/", $iy, $im);
+                $calmon->{'next_date'} = Date($iy, $im, 0);
+            }
+        }
+    }
+    return $calmon;
+}
+
+sub YearYear {
+    my ($year, $url, $displayed) = @_;
+    return { '_type' => "YearYear",
+             'year' => $year, 'url' => $url, 'displayed' => $displayed };
+}
+
+sub YearDay {
+    my ($u, $year, $month, $day, $count, $dow) = @_;
+    my $d = {
+        '_type' => 'YearDay',
+        'day' => $day,
+        'date' => Date($year, $month, $day, $dow),
+        'num_entries' => $count
+    };
+    if ($count) {
+        $d->{'url'} = sprintf("$u->{'_journalbase'}/$year/%02d/%02d/",
+                              $month, $day);
+    }
+    return $d;
+}
+
+1;

local/cgi-bin/LJR/GD.pm

@@ -0,0 +1,51 @@
+use strict;
+use GD::Simple;
+
+package LJR::GD;
+
+sub generate_number {
+  my ($num, $fontname, $fontcolor, $stuff) = @_;
+  
+  $num =~ s/^(\ +)//g;
+  $num =~ s/(\ +)$//g;
+  
+  my $font;
+  if ($fontname eq "gdTinyFont") {
+    $font = GD::Font->Tiny();
+  }
+  elsif ($fontname eq "gdSmallFont") {
+    $font = GD::Font->Small();
+  }
+  elsif ($fontname eq "gdLargeFont") {
+    $font = GD::Font->Large();
+  }
+  elsif ($fontname eq "gdMediumBoldFont") {
+    $font = GD::Font->MediumBold();
+  }
+  elsif ($fontname eq "gdGiantFont") {
+    $font = GD::Font->Giant();
+  }
+  else {
+    $font = GD::Font->Small();
+  }
+
+  my $cell_width = $font->width;
+  my $cell_height = $font->height;
+  my $cols = length($stuff) > length($num) ? length($stuff) : length($num);
+  my $width = int($cols * $cell_width + $cell_width / 3);
+  my $height = $cell_height + 1;
+  my $img = GD::Simple->new($width,$height);
+  $img->font($font);
+  $img->moveTo(1,$font->height + 1);
+  $img->transparent("white");
+  $img->bgcolor("white");
+  $img->fgcolor($fontcolor);
+  
+  my $str = (length($num) < length($stuff) ?
+    substr($stuff, 0, length($stuff) - length($num)) :
+    "") . $num;
+  $img->string($str);
+  return $img;
+}
+
+return 1;

local/cgi-bin/LJR/Gate.pm

@@ -0,0 +1,234 @@
+use strict;
+
+use XMLRPC::Lite;
+use Digest::MD5;
+use Time::Local;
+
+use LJR::Distributed;
+use LJR::xmlrpc;
+use LJR::Viewuserstandalone;
+
+require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
+
+package LJR::Gate;
+
+$LJR::Gate::clientver = 'LJR::Gate/0.02';
+
+sub Authenticate {
+  my ($server, $user, $pass) = @_;
+  
+  my $xmlrpc = new XMLRPC::Lite;
+  $xmlrpc->proxy("http://" . $server . "/interface/xmlrpc", timeout => 60);
+  
+  my $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.getchallenge");
+  return $xmlrpc_ret if $xmlrpc_ret->{"err_text"};
+
+  my $challenge = $xmlrpc_ret->{'result'}->{'challenge'};
+  my $response = Digest::MD5::md5_hex($challenge . Digest::MD5::md5_hex($pass));
+
+  my $xmlrpc_req = {
+    'username' => $user,
+    'auth_method' => 'challenge',
+    'auth_challenge' => $challenge,
+    'auth_response' => $response,
+    'ver' => 1,
+    'clientver' => $LJR::Gate::clientver,
+  };
+
+  $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.login", $xmlrpc_req);
+  return $xmlrpc_ret if $xmlrpc_ret->{"err_text"};
+  
+  return $xmlrpc;
+}
+
+sub ExportEntry {
+  my ($u, $req, $security, $jitemid, $anum) = @_;
+
+  return "User [" . $u->{'user'} . "] is not gated." unless LJR::Distributed::is_gated_local($u->{'user'});
+
+  my $dbr = LJ::get_db_reader();
+  return "Can't get database reader!" unless $dbr;
+  
+  my $r;
+  $r = $dbr->selectrow_hashref (
+    "SELECT * FROM ljr_export_settings WHERE user=?",
+    undef, $u->{'user'});
+
+  my $ru;
+  $ru = LJR::Distributed::get_cached_user({ 'ru_id' => $r->{'ru_id'}});
+  $ru = LJR::Distributed::get_remote_server_byid($ru);
+  
+  my $xmlrpc = new XMLRPC::Lite;
+  $xmlrpc->proxy($ru->{'servername'} . "/interface/xmlrpc", timeout => 60);
+  
+  my $xmlrpc_ret;
+  my $xmlrpc_req;
+  my $challenge;
+  my $response;
+  
+  my $real_event;
+  my $real_subject;
+
+  my $last_status;
+
+  if ($req->{'event'} !~ /\S/) {
+    $last_status = "removed entry.";
+
+    $real_event = $req->{'event'};
+    $real_subject = $req->{'subject'};
+  }
+  else {
+    my $item_url = LJ::item_link($u, $jitemid, $anum);
+    $last_status = "exported <a href=$item_url>entry</a>";
+    
+    $real_event = LJR::Viewuserstandalone::expand_ljuser_tags($req->{'event'});
+    $real_subject = LJR::Viewuserstandalone::expand_ljuser_tags($req->{'subject'});
+    
+    my $i=0;
+    while ($real_event =~ /lj-cut/ig) { $i++ };
+    while ($real_event =~ /\/lj-cut/ig) { $i-- };
+    if ($i gt 0) {
+      $real_event .= "</lj-cut>";
+    }
+    LJ::Poll::replace_polls_with_links(\$real_event);
+    LJ::EmbedModule->expand_entry($u, \$real_event, ('content_only' => 1));
+    
+    unless ($req->{'props'}->{'opt_nocomments'}) {
+      LJR::Distributed::sign_exported_gate_entry($u, $jitemid, $anum, \$real_event);
+    }
+  }
+  
+  $security = $req->{'sequrity'} if !$security && $req->{'security'};
+  $security = "public" unless $security;
+
+  $xmlrpc_req = {
+    'username' => $ru->{'username'},
+    'auth_method' => 'challenge',
+    'ver' => 1,
+    'clientver' => $LJR::Gate::clientver,
+    'subject' => $real_subject,
+    'event' => $real_event,
+    'year' => $req->{'year'},
+    'mon' => $req->{'mon'},
+    'day' => $req->{'day'},
+    'hour' => $req->{'hour'},
+    'min' => $req->{'min'},
+    'security' => $security,
+    'allowmask' => $req->{'allowmask'},
+    'props' => {
+      'current_moodid' => $req->{'props'}->{'current_moodid'},
+      'current_mood' => $req->{'props'}->{'current_mood'},
+      'current_music' => $req->{'props'}->{'current_music'},
+      'picture_keyword' => $req->{'props'}->{'picture_keyword'},
+      'taglist' => $req->{'props'}->{'taglist'},
+      'opt_backdated' => $req->{'props'}->{'opt_backdated'},
+      'opt_preformatted' => $req->{'props'}->{'opt_preformatted'},
+      'opt_nocomments' => 1,
+    },
+  };
+
+  my $is_invalid_remote_journal = sub {
+    my ($error_message) = @_;
+    if (
+      $error_message =~ /Invalid password/ ||
+      $error_message =~ /Selected journal no longer exists/ ||
+      $error_message =~ /account is suspended/ ||
+      $error_message =~ /Invalid username/
+      ) {
+      return 1;
+    }
+    return 0;
+  };
+  
+  my $is_invalid_remote_entry = sub {
+    my ($error_message) = @_;
+    if ($error_message =~ /Can\'t edit post from requested journal/) {
+      return 1;
+    }
+    return 0;
+  };
+
+  my $post_new_event = sub {
+    $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.getchallenge");
+    return $xmlrpc_ret->{"err_text"} if $xmlrpc_ret->{"err_text"};
+    $challenge = $xmlrpc_ret->{'result'}->{'challenge'};
+    $response = Digest::MD5::md5_hex($challenge . Digest::MD5::md5_hex($r->{'remote_password'}));
+    $xmlrpc_req->{'auth_challenge'} = $challenge;
+    $xmlrpc_req->{'auth_response'} = $response;
+
+    my $item_time = Time::Local::timelocal(0, $req->{'min'}, $req->{'hour'},
+      $req->{'day'}, $req->{'mon'} - 1, $req->{'year'});
+    
+    if ((time - $item_time) > 60*60*24) {
+      $xmlrpc_req->{'props'}->{'opt_backdated'} = 1;
+    }
+    
+    $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.postevent", $xmlrpc_req);
+    if ($xmlrpc_ret->{'err_text'}) {
+      if ($is_invalid_remote_journal->($xmlrpc_ret->{'err_text'})) {
+        $r = LJR::Distributed::update_export_status($u->{'user'}, 0, "ERROR: " . $xmlrpc_ret->{'err_text'});
+      }
+      else {
+        $r = LJR::Distributed::update_export_status($u->{'user'}, 1, "ERROR: " . $xmlrpc_ret->{'err_text'});
+      }
+      return $xmlrpc_ret->{"err_text"} . " " . ($r->{'err'} ? $r->{'errtext'} : "");
+    }
+
+    my $rhtml_id = $xmlrpc_ret->{'result'}->{'itemid'} * 256 +
+      $xmlrpc_ret->{'result'}->{'anum'};
+
+    $r = LJR::Distributed::store_remote_itemid(
+      $u,
+      $jitemid,
+      $ru->{'ru_id'},
+      $xmlrpc_ret->{'result'}->{'itemid'},
+      $rhtml_id,
+      "E"
+      );
+    return
+      "store_remote_itemid: " . $u->{'user'} . "," .
+      $jitemid . "," . $ru->{'ru_id'} . "," .
+      $xmlrpc_ret->{'result'}->{'itemid'} . "," . $rhtml_id . ": " .
+      $r->{"errtext"} if $r->{"err"};
+  };
+  
+  my $ritem = LJR::Distributed::get_remote_itemid($u->{'userid'}, $jitemid, "E");
+  if ($ritem && ($req->{'props'}->{'revnum'} || $req->{'event'} !~ /\S/)) {
+    $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.getchallenge");
+    return $xmlrpc_ret->{"err_text"} if $xmlrpc_ret->{"err_text"};
+    $challenge = $xmlrpc_ret->{'result'}->{'challenge'};
+    $response = Digest::MD5::md5_hex($challenge . Digest::MD5::md5_hex($r->{'remote_password'}));
+    $xmlrpc_req->{'auth_challenge'} = $challenge;
+    $xmlrpc_req->{'auth_response'} = $response;
+
+    $xmlrpc_req->{'itemid'} = $ritem->{'ritemid'};
+    
+    $xmlrpc_ret = LJR::xmlrpc::xmlrpc_call($xmlrpc, "LJ.XMLRPC.editevent", $xmlrpc_req);
+    if ($xmlrpc_ret->{'err_text'}) {
+      if ($is_invalid_remote_entry->($xmlrpc_ret->{'err_text'})) {
+        LJR::Distributed::remove_remote_itemid($u, $jitemid, $ru->{'ru_id'}, $ritem->{'ritemid'}, "E");
+        my $errmsg = $post_new_event->();
+        return $errmsg if $errmsg;
+      }
+      elsif ($is_invalid_remote_journal->($xmlrpc_ret->{'err_text'})) {
+        $r = LJR::Distributed::update_export_status($u->{'user'}, 0, "ERROR: " . $xmlrpc_ret->{'err_text'});
+        return $xmlrpc_ret->{"err_text"} . " " . ($r->{'err'} ? $r->{'errtext'} : "");
+      }
+      $r = LJR::Distributed::update_export_status($u->{'user'}, 1, "ERROR: " . $xmlrpc_ret->{'err_text'});
+      return $xmlrpc_ret->{"err_text"} . " " . ($r->{'err'} ? $r->{'errtext'} : "");
+    }
+    if ($req->{'event'} !~ /\S/) {
+      LJR::Distributed::remove_remote_itemid($u, $jitemid, $ru->{'ru_id'}, $ritem->{'ritemid'}, "E");
+    }
+
+  }
+  else {
+    my $errmsg = $post_new_event->();
+    return $errmsg if $errmsg;
+  }
+  
+  $r = LJR::Distributed::update_export_status($u->{'user'}, 1, "OK: $last_status");
+  return $r->{'errtext'} if $r->{'err'};
+    
+  return;
+}

local/cgi-bin/LJR/Viewuser.pm

@@ -0,0 +1,241 @@
+package LJR::Viewuser;
+
+use strict;
+use Carp;
+use lib "$ENV{'LJHOME'}/cgi-bin";
+use DBI;
+use DBI::Role;
+use DBIx::StateKeeper;     
+
+# A function to canonicalize sitename: take one of the possible
+# abbreviations for a given known site, and returns the siteid
+# from the list. Otherwise, assume that abbreivation is actually the
+# full URL, and return it "as is", without the possible leading http://.
+#
+# We check the known servers database for "site=servername" or "site
+# contains serverurl without the leading www"; make additional
+# explicit matchings if necessary (presently none are necessary), et
+# voila. 
+#
+
+sub canonical_sitenum {
+    my ($site)=@_;
+
+# Cut away leading http://
+    $site =~ s|http://(.*)|$1|;
+
+    my $dbh = LJ::get_db_reader();
+    my $sth = $dbh->prepare(
+      "SELECT serverid FROM alienservers WHERE servername=?"
+      );
+    
+    $sth->execute($site);
+    return LJ::error($dbh) if $dbh->err;
+#
+# Match $site=servername (e.g. "LJ")
+#
+    if ($sth->rows) {
+      my ($guu) = $sth->fetchrow_array;
+      return $guu;
+    }
+    $sth->finish;
+
+    $sth = $dbh->prepare(
+      "SELECT serverid, REPLACE(serverurl, 'www.', '') FROM alienservers"
+      );
+    $sth->execute;
+    return LJ::error($dbh) if $dbh->err;
+#
+# Scan all known servers and match "serverurl without www is
+#    contained in $site"
+#
+    while (my ($hale, $guu) = $sth->fetchrow_array) {
+	if (index ($site, $guu) !=-1) {
+	  return $hale;
+	}
+    }
+
+    if ( (lc($site) eq "ljr") || ($site =~ m/.*${LJ::DOMAIN}.*/) )
+#
+# 0 means ourselves
+#
+       {return 0;}  
+#    elsif ( ($site eq "LJ") || ($site =~ m/.*livejournal\.com.*/) )
+#       {return 1;}  
+#    elsif ( ($site eq "GJ") || ($site =~ m/.*greatestjournal\.com.*/) )
+#       {return 2;}  
+#    elsif ( ($site eq "NPJ") || ($site =~ m/.*npj\.ru.*/) )
+#       {return 3;}  
+   else {return $site};
+
+}
+
+#
+# Provides a representation of a user. 
+#
+# Format: we receive a username and a site, where site is either a
+# number or a string. If a non-zero number, this is a known site; we take
+# information about it from the alianservers table in the db. If
+# zero, site is ourselves. If a string, we do not know anything about
+# the site and treat it as an OpenID guest; we assume site is the URL.
+#
+# We return the HTML code.
+#
+# <lj user="username" site="sitename"> should be expand to
+#  ljuser( $username, {'site'=> canonical_sitenum($sitename), 
+#           'type'=>'P'} )
+#
+#  For lj comm, replace 'P' with 'C'
+#
+
+sub ljuser {
+    # we assume $opts->{'site'} to be a siteid of a known site or a full
+    # URL of a site we do not have in db
+    my $user = shift;
+    my $opts = shift;
+    my $u;
+    my $native=0;
+    my $known=0;
+
+    my $name="";
+    my $url;
+    my $uicon;
+    my $cicon;
+    my $commdir;
+    my $udir;
+    my $lj_type;
+
+# If site is not given, assume native (siteid=0)
+    unless ($opts->{'site'}) {$opts->{'site'}=0;}
+
+# Check if site is a number
+    if($opts->{'site'} =~ m/(\d+)/) 
+    { $known=1; }
+
+    if($known) {
+
+# Site a number (known site)
+
+	$opts->{'site'} = $opts->{'site'}+0;
+
+	# now we've got default - $LJ::DOMAIN
+
+	if ($opts->{'site'}==0){
+
+        # local
+	    $url=$LJ::DOMAIN;
+	    $cicon='community.gif'; # default local commicon
+	    $uicon='userinfo.gif'; # default local usericon
+	    $commdir='community/';
+	    $udir='users/';
+	    $lj_type='Y';
+
+	    $native=1;
+	} else {
+
+        # alien but known --
+	# go to db to get $name
+
+	       my $dbh = LJ::get_db_writer();
+	       my $sth = $dbh->prepare("SELECT serverurl, servername, udir, uicon, cdir, cicon, ljtype FROM alienservers WHERE serverid=?");
+	       $sth->execute($opts->{'site'});                                                                                                                       
+		($url, $name, $udir, $uicon, $commdir, $cicon, $lj_type) = $sth->fetchrow_array;       
+	    $native=0;
+	}
+    } else {
+
+# site is not a number -- unknown alien site
+
+	$name=$opts->{'site'};
+	$url=$opts->{'site'};
+	$uicon='openid-profile.gif'; # default unknown alien usericon
+	$cicon='openid-profile.gif'; # default unknown alien commicon
+	$commdir='';
+	$udir='';
+	$lj_type='N';
+	$native=0;
+
+    }
+                                                                                                           
+    if ($native){                 
+
+# If the user is local, we do some processing: check validity, check
+# whether user or community, etc.
+
+#        my $do_dynamic = $LJ::DYNAMIC_LJUSER || ($user =~ /^ext_/);                                            
+#        if ($do_dynamic && ! isu($user) && ! $opts->{'type'}) {                                                
+            # Try to automatically pick the user type, but still                                               
+            # make something if we can't (user doesn't exist?)                                                 
+            $user = LJ::load_user($user) || $user;                                                             
+                                                                                                               
+            my $hops = 0;                                                                                      
+                                                                                                               
+            # Traverse the renames to the final journal                                                        
+            while (ref $user and $user->{'journaltype'} eq 'R'                                                 
+               and ! $opts->{'no_follow'} && $hops++ < 5) {                                                    
+                                                                                                               
+        	LJ::load_user_props($user, 'renamedto');                                                           
+        	last unless length $user->{'renamedto'};                                                           
+        	$user = LJ::load_user($user->{'renamedto'});                                                       
+                                                                                                               
+            }                                                                                                  
+#	}                                                                                                          
+                                                                                                               
+    	    if (LJ::isu($user)) {                                                                                          
+		$u = $user;                                                                                            
+    		$opts->{'type'} = $user->{'journaltype'};                                                              
+                # Mark accounts as deleted that aren't visible, memorial, or locked                                    
+	        $opts->{'del'} = $user->{'statusvis'} ne 'V' &&                                                        
+    		    $user->{'statusvis'} ne 'M' &&                                                                     
+        	    $user->{'statusvis'} ne 'L';                                                                       
+        	$user = $user->{'user'};                                                                               
+	    }
+    }
+  
+
+# End of local-specific part
+  
+    my $andfull = $opts->{'full'} ? "&amp;mode=full" : "";                                                     
+    my $img = $opts->{'imgroot'} || $LJ::IMGPREFIX;                                                            
+    my $strike = $opts->{'del'} ? ' text-decoration: line-through;' : '';                                      
+    my $make_tag = sub {                                                                                       
+        my ($s, $n, $fil, $dir) = @_;                                                                          
+	$n = lc ($n);
+
+	    if ($n eq ""){
+                return "<span class='ljruser' style='white-space: nowrap;$strike'><a href='http://$s/userinfo.bml?user=$user$andfull'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user</b></a></span>";
+	    } else { 
+		if ($lj_type eq 'Y') {
+
+# If the site is known and has an lj-type engine, then we now how to
+# refer to userinfo; make the info icon link to this
+	
+	    return "<span class='ljruser' style='white-space: nowrap;$strike'><a href='http://$s/userinfo.bml?user=$user$andfull'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user\@$n</b></a></span>";
+		} elsif ($known) {
+
+# If not lj-type, but known, let the info icon link to the user journal
+
+		    return "<span class='ljruser' style='white-space: nowrap;$strike'><a href='http://$s/$dir$user/'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user\@$n</b></a></span>";
+		} else {
+
+# Unknown site. Treat as openid
+
+		    return "<span class='ljruser' style='white-space: nowrap;$strike'><a href='http://$s/$dir$user/'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user</b> [$n]</a></span>";
+                }
+	    }
+        };                                                                                                     
+                                                                                                               
+        if ($opts->{'type'} eq 'C') {                                                                          
+            return $make_tag->( $url, $name, $cicon, $commdir);                            
+        } elsif ($opts->{'type'} eq 'Y') {                                                                     
+            return $make_tag->( $url, $name, 'syndicated.gif', 'users/');                               
+        } elsif ($opts->{'type'} eq 'N') {                                                                     
+            return $make_tag->( $url, $name, 'newsinfo.gif', 'users/');                                 
+        } elsif ($opts->{'type'} eq 'I') {                                                                     
+            return $u->ljuser_display($opts);                                                                  
+        } else {                                                                                               
+            return $make_tag->( $url, $name, $uicon, $udir);                                 
+        }                                                                                                      
+};
+
+1;

local/cgi-bin/LJR/Viewuserstandalone.pm

@@ -0,0 +1,210 @@
+package LJR::Viewuserstandalone;
+
+use strict;
+
+# A function to canonicalize sitename: take one of the possible
+# abbreviations for a given known site, and returns the siteid
+# from the list. Otherwise, assume that abbreivation is actually the
+# full URL, and return it "as is", without the possible leading http://.
+# Right now we work case-by-case, since the number of known
+# abbreviations is small.
+#
+#
+# Known sites:
+#
+# 0 -- local
+# 1 -- www.livejournal.com
+# 2 -- greatestjournal.com
+# 3 -- npj.ru
+# 4 -- dreamwidth.org 
+# TODO: add third level domains
+
+sub canonical_sitenum {
+    my ($site)=@_;
+
+    if ( ($site eq "LJR") || ($site =~ m/.*lj\.rossia\.org.*/) )
+       {return 0;}  
+    elsif ( ($site eq "LJ") || ($site =~ m/.*livejournal\.com.*/) )
+       {return 1;}  
+    elsif ( ($site eq "GJ") || ($site =~ m/.*greatestjournal\.com.*/) )
+       {return 2;}  
+    elsif ( ($site eq "NPJ") || ($site =~ m/.*npj\.ru.*/) )
+       {return 3;}  
+    elsif ( ($site eq "DW") || ($site eq "dw") || ($site =~ m/.*dreamwidth\.org.*/) )
+       {return 4;}  
+    else {return $site;}
+}
+
+#
+# Provides a representation of a user. 
+#
+# Format: we receive a username and a site, where site is either a
+# number or a string. If a non-zero number, this is a known site; we take
+# information about it from the alianservers table in the db. If
+# zero, site is ourselves. If a string, we do not know anything about
+# the site and treat it as an OpenID guest; we assume site is the URL.
+#
+# We return the HTML code.
+#
+# <lj user="username" site="sitename"> should be expand to
+#  ljuser( $username, {'site'=> canonical_sitenum($sitename), 
+#           'type'=>'P','imgroot'=>''} )
+#
+#  For lj comm, replace 'P' with 'C'; 'imgroot' should be equal to the
+#  current value of $LJ::IMGPREFIX -- right now it is differs
+#  between test and production!!
+#
+
+sub ljuser {
+    # we assume $opts->{'site'} to be a siteid of a known site or a full
+    # URL of a site we do not have in db
+    my $user = shift;
+    my $opts = shift;
+    my $u;
+
+    my $name="";
+    my $url;
+    my $uicon;
+    my $cicon;
+    my $commdir;
+    my $udir;
+    my $lj_type;
+
+# If site is not given, assume native (siteid=0)
+    unless ($opts->{'site'}) {$opts->{'site'}=0;}
+
+# Check if site is a number
+    if($opts->{'site'} =~ m/(\d+)/) {
+
+# Site a number (known site)
+
+	$opts->{'site'} = $opts->{'site'}+0;
+
+	# now we've got default - $LJ::DOMAIN
+
+	if ($opts->{'site'}==0){
+
+        # local
+	    $url='lj.rossia.org';
+	    $cicon='community.gif'; # default local commicon
+	    $uicon='userinfo.gif'; # default local usericon
+	    $commdir='community/';
+	    $udir='users/';
+	    $lj_type='Y';
+	} elsif ($opts->{'site'}==1) {
+        # LJ
+            $name="LJ";
+	    $url='www.livejournal.com';
+	    $cicon='community-lj.gif';
+	    $uicon='userinfo-lj.gif';
+	    $commdir='community/';
+	    $udir='users/';
+	    $lj_type='Y';
+	} elsif ($opts->{'site'}==2) {
+        # GJ
+            $name="GJ";
+	    $url='www.greatestjournal.com';
+	    $cicon='community-lj.gif';
+	    $uicon='userinfo-lj.gif';
+	    $commdir='community/';
+	    $udir='users/';
+	    $lj_type='Y';
+	} elsif ($opts->{'site'}==3) {
+        # LJ
+            $name="NPJ";
+	    $url='www.npj.ru';
+	    $cicon='community-npj.gif';
+	    $uicon='userinfo-npj.gif';
+	    $commdir='';
+	    $udir='';
+	    $lj_type='N';
+	} elsif ($opts->{'site'}==4) {
+        # DW
+            $name="DW";
+	    $url='www.dreamwidth.org';
+	    $cicon='community-dw.gif';
+	    $uicon='userinfo-dw.gif';
+	    $commdir='community/';
+	    $udir='users/';
+	    $lj_type='Y';
+        } else { return "[Unknown LJ user tag]"; }
+
+    } else {
+
+# site is not a number -- unknown alien site
+
+	$name=$opts->{'site'};
+	$url=$opts->{'site'};
+	$uicon=''; # default unknown alien usericon
+	$cicon=''; # default unknown alien commicon
+	$commdir='community';
+	$udir='users';
+	$lj_type='N';
+    }
+
+  
+    my $andfull = $opts->{'full'} ? "&amp;mode=full" : "";
+
+    my $img = $opts->{'imgroot'};
+    my $make_tag = sub {
+        my ($s, $n, $fil, $dir) = @_;
+	    if ($n eq ""){
+                return "<span class='ljruser' style='white-space: nowrap;'><a href='http://$s/userinfo.bml?user=$user$andfull'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user</b></a></span>";
+	    } else { 
+		if ($lj_type eq 'Y') {
+
+# If the site is known and has an lj-type engine, then we now how to
+# refer to userinfo; make the info icon link to this
+	
+	    return "<span class='ljruser' style='white-space: nowrap;'><a href='http://$s/userinfo.bml?user=$user$andfull'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user</b> [$n]</a></span>";
+		} else {
+
+# If not lj-type, let the info icon link to the user journal
+
+		    return "<span class='ljruser' style='white-space: nowrap;'><a href='http://$s/$dir$user/'><img src='$img/$fil' alt='[info]' style='vertical-align: bottom; border: 0;' /></a><a href='http://$s/$dir$user/'><b>$user</b> [$n]</a></span>";
+		}
+	    }
+        };
+        if ($opts->{'type'} eq 'C') {
+            return $make_tag->( $url, $name, $cicon, $commdir);
+        } else {
+            return $make_tag->( $url, $name, $uicon, $udir);
+        }
+}                  
+
+sub expand_ljuser_tags {
+
+    my ($string)=@_;
+    
+    return "" unless $string;
+    
+    my $imgroot='http://lj.rossia.org/img';
+
+    $string=~ s/<lj\s+user=\"?(\w+)\"?\s+site=\"?([^"]+)\"?\s*\/?>/
+	ljuser($1,{
+	    'site'=>canonical_sitenum($2),
+	    'type'=>'P','imgroot'=>$imgroot,
+	})
+    /egxi;
+    $string=~ s/<lj\s+comm=\"?(\w+)\"?\s+site=\"?([^"]+)\"?\s*\/?>/
+        ljuser($1,{
+            'site'=>canonical_sitenum($2),
+            'type'=>'C','imgroot'=>$imgroot,
+        })
+    /egxi;
+    $string=~ s/<ljr\s+user=\"?(\w+)\"?\s*\/?>/
+        ljuser($1,{
+            'site'=>0,
+            'type'=>'P','imgroot'=>$imgroot,
+        })
+	/egxi;
+    $string=~ s/<ljr\s+comm=\"?(\w+)\"?\s*\/?>/
+        ljuser($1,{
+            'site'=>0,
+            'type'=>'C','imgroot'=>$imgroot,
+        })
+        /egxi;
+    return $string;
+}
+
+1;

local/cgi-bin/LJR/ljpoll-local.pl

@@ -0,0 +1,25 @@
+package LJ::Poll;
+
+use strict;
+
+sub replace_polls_with_links {
+  my ($event) = @_;
+
+  my $dbr = LJ::get_db_reader();
+
+  while ($$event =~ /<lj-poll-(\d+)>/g) {
+      my $pollid = $1;
+      my $name = $dbr->selectrow_array("SELECT name FROM poll WHERE pollid=?",
+                                       undef, $pollid);
+
+      if ($name) {
+          LJ::Poll::clean_poll(\$name);
+      } else {
+          $name = "#$pollid";
+      }
+
+      $$event =~ s!<lj-poll-$pollid>!<div><a href="$LJ::SITEROOT/poll/?id=$pollid">View Poll: $name</a></div>!g;
+  }
+}
+
+return 1;

local/cgi-bin/LJR/unicode.pm

@@ -0,0 +1,53 @@
+use strict;
+
+package LJR::unicode;
+
+use XML::Parser;
+use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset);
+
+
+sub utf8ize {
+  my $text_in = shift;
+  $$text_in = pack("C*", unpack("C*", $$text_in)) if $$text_in;
+}
+
+
+sub force_utf8 {
+  my $xdata = shift;
+  my %error_lines;
+  my $finished = 0;
+  my @xlines;
+  my $orig_xdata = $$xdata;
+
+  my $p1 = new XML::Parser ();
+
+  while (!$finished) {
+    eval { $p1->parse($$xdata); };
+
+    if ($@ && $@ =~ /not\ well\-formed\ \(invalid\ token\)\ at\ line\ (\d+)\,/) {
+      my $error_line = $1;
+      $error_lines{$error_line} ++;
+
+      if ($error_lines{$error_line} > 1) {
+        $$xdata = $orig_xdata;
+        $finished = 1;
+      }
+      else {
+        @xlines = split(/\n/, $$xdata);
+        my $output = to_utf8({ -string => $xlines[$error_line - 1], -charset => 'latin1' });
+        $xlines[$error_line - 1] = $output;
+        $$xdata = join("\n", @xlines);
+      }
+    }
+    # unknown error or no error, doesn't matter
+    elsif ($@) {
+      $$xdata = $orig_xdata;
+      $finished = 1;
+    }
+    else {
+      $finished = 1;
+    }
+  }
+}
+
+return 1;

local/cgi-bin/LJR/xmlrpc.pm

@@ -0,0 +1,28 @@
+use strict;
+
+package LJR::xmlrpc;
+
+sub xmlrpc_call {
+  my ($xmlrpc, $method, $request) = @_;
+  my $res;
+  
+  if ($xmlrpc) {
+    $res = $xmlrpc->call ($method, $request);
+    
+    if ($res && $res->fault) {
+      $res->{"err_text"} = $method . ":  " . "XML-RPC Error [" . $res->faultcode . "]: " . $res->faultstring;
+    }
+    elsif (!$res) {
+      $res->{"err_text"} = $method . ":  " . "Unknown XML-RPC Error.";
+    }
+   
+    $res->{"result"} = $res->result;
+  }
+  else {
+    $res->{"err_text"} = "Invalid xmlrpc object";
+  }
+  
+  return $res;
+}
+
+return 1;

local/cgi-bin/LWPx/ParanoidAgent.pm

@@ -0,0 +1,585 @@
+package LWPx::ParanoidAgent;
+require LWP::UserAgent;
+
+use vars qw(@ISA $VERSION);
+@ISA = qw(LWP::UserAgent);
+$VERSION = '1.02';
+
+require HTTP::Request;
+require HTTP::Response;
+
+use HTTP::Status ();
+use strict;
+use Net::DNS;
+use LWP::Debug;
+
+sub new {
+    my $class = shift;
+    my %opts = @_;
+
+    my $blocked_hosts     = delete $opts{blocked_hosts}     || [];
+    my $whitelisted_hosts = delete $opts{whitelisted_hosts} || [];
+    my $resolver          = delete $opts{resolver};
+    $opts{timeout}      ||= 15;
+
+    my $self = LWP::UserAgent->new( %opts );
+
+    $self->{'blocked_hosts'}     = $blocked_hosts;
+    $self->{'whitelisted_hosts'} = $whitelisted_hosts;
+    $self->{'resolver'}          = $resolver;
+
+    $self = bless $self, $class;
+    return $self;
+}
+
+# returns seconds remaining given a request
+sub _time_remain {
+    my $self = shift;
+    my $req = shift;
+
+    my $now = time();
+    my $start_time = $req->{_time_begin} || $now;
+    return $start_time + $self->{timeout} - $now;
+}
+
+sub _resolve {
+    my ($self, $host, $request, $timeout, $depth) = @_;
+    my $res = $self->resolver;
+    $depth ||= 0;
+
+    die "CNAME recursion depth limit exceeded.\n" if $depth > 10;
+    die "Suspicious results from DNS lookup" if $self->_bad_host($host);
+
+    # return the IP address if it looks like one and wasn't marked bad
+    return ($host) if $host =~ /^\d+\.\d+\.\d+\.\d+$/;
+
+    my $sock = $res->bgsend($host)
+        or die "No sock from bgsend";
+
+    my $rin = '';
+    vec($rin, fileno($sock), 1) = 1;
+    my $nf = select($rin, undef, undef, $self->_time_remain($request));
+    die "DNS lookup timeout" unless $nf;
+
+    my $packet = $res->bgread($sock)
+        or die "DNS bgread failure";
+    $sock = undef;
+
+    my @addr;
+    my $cname;
+    foreach my $rr ($packet->answer) {
+        if ($rr->type eq "A") {
+            die "Suspicious DNS results from A record\n" if $self->_bad_host($rr->address);
+            push @addr, $rr->address;
+        } elsif ($rr->type eq "CNAME") {
+            # will be checked for validity in the recursion path
+            $cname = $rr->cname;
+        }
+    }
+
+    return @addr if @addr;
+    return () unless $cname;
+    return $self->_resolve($cname, $request, $timeout, $depth + 1);
+}
+
+sub _host_list_match {
+    my $self = shift;
+    my $list_name = shift;
+    my $host = shift;
+
+    foreach my $rule (@{ $self->{$list_name} }) {
+        if (ref $rule eq "CODE") {
+            return 1 if $rule->($host);
+        } elsif (ref $rule) {
+            # assume regexp
+            return 1 if $host =~ /$rule/;
+        } else {
+            return 1 if $host eq $rule;
+        }
+    }
+}
+
+sub _bad_host {
+    my $self = shift;
+    my $host = lc(shift);
+
+    return 0 if $self->_host_list_match("whitelisted_hosts", $host);
+    return 1 if $self->_host_list_match("blocked_hosts", $host);
+    return 1 if
+        $host =~ /^localhost$/i ||    # localhost is bad.  even though it'd be stopped in
+                                      #    a later call to _bad_host with the IP address
+        $host =~ /\s/i;               # any whitespace is questionable
+
+    # Let's assume it's an IP address now, and get it into 32 bits.
+    # Uf at any time something doesn't look like a number, then it's
+    # probably a hostname and we've already either whitelisted or
+    # blacklisted those, so we'll just say it's okay and it'll come
+    # back here later when the resolver finds an IP address.
+    my @parts = split(/\./, $host);
+    return 0 if @parts > 4;
+
+    # un-octal/un-hex the parts, or return if there's a non-numeric part
+    my $overflow_flag = 0;
+    foreach (@parts) {
+        return 0 unless /^\d+$/ || /^0x[a-f\d]+$/;
+        local $SIG{__WARN__} = sub { $overflow_flag = 1; };
+        $_ = oct($_) if /^0/;
+    }
+
+    # a purely numeric address shouldn't overflow.
+    return 1 if $overflow_flag;
+
+    my $addr;  # network order packed IP address
+
+    if (@parts == 1) {
+        # a - 32 bits
+        return 1 if
+            $parts[0] > 0xffffffff;
+        $addr = pack("N", $parts[0]);
+    } elsif (@parts == 2) {
+        # a.b - 8.24 bits
+        return 1 if
+            $parts[0] > 0xff ||
+            $parts[1] > 0xffffff;
+        $addr = pack("N", $parts[0] << 24 | $parts[1]);
+    } elsif (@parts == 3) {
+        # a.b.c - 8.8.16 bits
+        return 1 if
+            $parts[0] > 0xff ||
+            $parts[1] > 0xff ||
+            $parts[2] > 0xffff;
+        $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2]);
+    } else {
+        # a.b.c.d - 8.8.8.8 bits
+        return 1 if
+            $parts[0] > 0xff ||
+            $parts[1] > 0xff ||
+            $parts[2] > 0xff ||
+            $parts[3] > 0xff;
+        $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2] << 8 | $parts[3]);
+    }
+
+    my $haddr = unpack("N", $addr); # host order IP address
+    return 1 if
+        ($haddr & 0xFF000000) == 0x00000000 || # 0.0.0.0/8
+        ($haddr & 0xFF000000) == 0x0A000000 || # 10.0.0.0/8
+        ($haddr & 0xFF000000) == 0x7F000000 || # 127.0.0.0/8
+        ($haddr & 0xFFF00000) == 0xAC100000 || # 172.16.0.0/12
+        ($haddr & 0xFFFF0000) == 0xA9FE0000 || # 169.254.0.0/16
+        ($haddr & 0xFFFF0000) == 0xC0A80000 || # 192.168.0.0/16
+         $haddr               == 0xFFFFFFFF || # 255.255.255.255
+        ($haddr & 0xF0000000) == 0xE0000000;  # multicast addresses
+
+    # as final IP address check, pass in the canonical a.b.c.d decimal form
+    # to the blacklisted host check to see if matches as bad there.
+    my $can_ip = join(".", map { ord } split //, $addr);
+    return 1 if $self->_host_list_match("blocked_hosts", $can_ip);
+
+    # looks like an okay IP address
+    return 0;
+}
+
+sub request {
+    my ($self, $req, $arg, $size, $previous) = @_;
+
+    # walk back to the first request, and set our _time_begin to its _time_begin, or if
+    # we're the first, then use current time.  used by LWPx::Protocol::http_paranoid
+    my $first_res = $previous;  # previous is the previous response that invoked this request
+    $first_res = $first_res->previous while $first_res && $first_res->previous;
+    $req->{_time_begin} = $first_res ? $first_res->request->{_time_begin} : time();
+
+    my $host = $req->uri->host;
+    if ($self->_bad_host($host)) {
+        my $err_res = HTTP::Response->new(403, "Unauthorized access to blocked host");
+        $err_res->request($req);
+        $err_res->header("Client-Date" => HTTP::Date::time2str(time));
+        $err_res->header("Client-Warning" => "Internal response");
+        $err_res->header("Content-Type" => "text/plain");
+        $err_res->content("403 Unauthorized access to blocked host\n");
+        return $err_res;
+    }
+
+    return $self->SUPER::request($req, $arg, $size, $previous);
+}
+
+sub redirect_ok
+{
+    # RFC 2616, section 10.3.2 and 10.3.3 say:
+    #  If the 30[12] status code is received in response to a request other
+    #  than GET or HEAD, the user agent MUST NOT automatically redirect the
+    #  request unless it can be confirmed by the user, since this might
+    #  change the conditions under which the request was issued.
+
+    # Note that this routine used to be just:
+    #  return 0 if $_[1]->method eq "POST";  return 1;
+
+    my($self, $new_request, $response) = @_;
+    my $method = $response->request->method;
+    return 0 unless grep $_ eq $method,
+      @{ $self->requests_redirectable || [] };
+
+    if ($new_request->url->scheme eq 'file') {
+      $response->header("Client-Warning" =>
+                        "Can't redirect to a file:// URL!");
+      return 0;
+    }
+
+    $self->{'final_url'} = $new_request->uri;
+
+    # Otherwise it's apparently okay...
+    return 1;
+}
+
+# taken from LWP::UserAgent and modified slightly.  (proxy support removed,
+# and map http and https schemes to separate protocol handlers)
+sub send_request
+{
+    my ($self, $request, $arg, $size) = @_;
+    $self->_request_sanity_check($request);
+
+    my ($method, $url) = ($request->method, $request->uri);
+
+    local($SIG{__DIE__});  # protect against user defined die handlers
+
+    # Check that we have a METHOD and a URL first
+    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Method missing")
+        unless $method;
+    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL missing")
+        unless $url;
+    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
+        unless $url->scheme;
+    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST,
+                         "ParanoidAgent doesn't support going through proxies.  ".
+                         "In that case, do your paranoia at your proxy instead.")
+        if $self->_need_proxy($url);
+
+    my $scheme = $url->scheme;
+    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Only http and https are supported by ParanoidAgent")
+        unless $scheme eq "http" || $scheme eq "https";
+
+    LWP::Debug::trace("$method $url");
+
+    my $protocol;
+
+    {
+      # Honor object-specific restrictions by forcing protocol objects
+      #  into class LWP::Protocol::nogo.
+        my $x;
+        if($x       = $self->protocols_allowed) {
+            if(grep lc($_) eq $scheme, @$x) {
+                LWP::Debug::trace("$scheme URLs are among $self\'s allowed protocols (@$x)");
+              }
+            else {
+                LWP::Debug::trace("$scheme URLs aren't among $self\'s allowed protocols (@$x)");
+                  require LWP::Protocol::nogo;
+                  $protocol = LWP::Protocol::nogo->new;
+              }
+        }
+        elsif ($x = $self->protocols_forbidden) {
+            if(grep lc($_) eq $scheme, @$x) {
+                LWP::Debug::trace("$scheme URLs are among $self\'s forbidden protocols (@$x)");
+                  require LWP::Protocol::nogo;
+                  $protocol = LWP::Protocol::nogo->new;
+              }
+            else {
+                LWP::Debug::trace("$scheme URLs aren't among $self\'s forbidden protocols (@$x)");
+              }
+        }
+      # else fall thru and create the protocol object normally
+    }
+
+    unless ($protocol) {
+        LWP::Protocol::implementor("${scheme}_paranoid",  "LWPx::Protocol::${scheme}_paranoid");
+        eval "require LWPx::Protocol::${scheme}_paranoid;";
+        if ($@) {
+            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+            my $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
+            return $response;
+        }
+
+        $protocol = eval { LWP::Protocol::create($scheme eq "http" ? "http_paranoid" : "https_paranoid", $self) };
+        if ($@) {
+            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+            my $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
+            if ($scheme eq "https") {
+                $response->message($response->message . " (Crypt::SSLeay not installed)");
+                $response->content_type("text/plain");
+                $response->content(<<EOT);
+LWP will support https URLs if the Crypt::SSLeay module is installed.
+More information at <http://www.linpro.no/lwp/libwww-perl/README.SSL>.
+EOT
+}
+            return $response;
+        }
+    }
+
+    # Extract fields that will be used below
+    my ($timeout, $cookie_jar, $use_eval, $parse_head, $max_size) =
+        @{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};
+
+    my $response;
+    my $proxy = undef;
+    if ($use_eval) {
+        # we eval, and turn dies into responses below
+        eval {
+            $response = $protocol->request($request, $proxy,
+                                           $arg, $size, $timeout);
+        };
+        if ($@) {
+            $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+            $response = _new_response($request,
+                                      &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+                                      $@);
+        }
+    }
+    else {
+        $response = $protocol->request($request, $proxy,
+                                       $arg, $size, $timeout);
+        # XXX: Should we die unless $response->is_success ???
+    }
+
+    $response->request($request);  # record request for reference
+    $cookie_jar->extract_cookies($response) if $cookie_jar;
+    $response->header("Client-Date" => HTTP::Date::time2str(time));
+    return $response;
+}
+
+# blocked hostnames, compiled patterns, or subrefs
+sub blocked_hosts
+{
+    my $self = shift;
+    if (@_) {
+        my @hosts = @_;
+        $self->{'blocked_hosts'} = \@hosts;
+        return;
+    }
+    return @{ $self->{'blocked_hosts'} };
+}
+
+# whitelisted hostnames, compiled patterns, or subrefs
+sub whitelisted_hosts
+{
+    my $self = shift;
+    if (@_) {
+        my @hosts = @_;
+        $self->{'whitelisted_hosts'} = \@hosts;
+        return;
+    }
+    return @{ $self->{'whitelisted_hosts'} };
+}
+
+# get/set Net::DNS resolver object
+sub resolver
+{
+    my $self = shift;
+    if (@_) {
+        $self->{'resolver'} = shift;
+        require UNIVERSAL ;
+        die "Not a Net::DNS::Resolver object" unless
+            UNIVERSAL::isa($self->{'resolver'}, "Net::DNS::Resolver");
+    }
+    return $self->{'resolver'} ||= Net::DNS::Resolver->new;
+}
+
+# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
+# staying there in future versions:  needed by our modified version of send_request
+sub _need_proxy
+{
+    my($self, $url) = @_;
+    $url = $HTTP::URI_CLASS->new($url) unless ref $url;
+
+    my $scheme = $url->scheme || return;
+    if (my $proxy = $self->{'proxy'}{$scheme}) {
+        if (@{ $self->{'no_proxy'} }) {
+            if (my $host = eval { $url->host }) {
+                for my $domain (@{ $self->{'no_proxy'} }) {
+                    if ($host =~ /\Q$domain\E$/) {
+                        LWP::Debug::trace("no_proxy configured");
+                          return;
+                      }
+                }
+            }
+        }
+        LWP::Debug::debug("Proxied to $proxy");
+        return $HTTP::URI_CLASS->new($proxy);
+    }
+    LWP::Debug::debug('Not proxied');
+    undef;
+}
+
+# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
+# staying there in future versions:  needed by our modified version of send_request
+sub _request_sanity_check {
+    my($self, $request) = @_;
+    # some sanity checking
+    if (defined $request) {
+        if (ref $request) {
+            Carp::croak("You need a request object, not a " . ref($request) . " object")
+              if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
+              !$request->can('method') or !$request->can('uri');
+          }
+        else {
+            Carp::croak("You need a request object, not '$request'");
+          }
+    }
+    else {
+        Carp::croak("No request object passed in");
+      }
+}
+
+# Taken directly from LWP::UserAgent because it was private there, and we can't depend on it
+# staying there in future versions:  needed by our modified version of send_request
+sub _new_response {
+    my($request, $code, $message) = @_;
+    my $response = HTTP::Response->new($code, $message);
+    $response->request($request);
+    $response->header("Client-Date" => HTTP::Date::time2str(time));
+    $response->header("Client-Warning" => "Internal response");
+    $response->header("Content-Type" => "text/plain");
+    $response->content("$code $message\n");
+    return $response;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWPx::ParanoidAgent - subclass of LWP::UserAgent that protects you from harm
+
+=head1 SYNOPSIS
+
+ require LWPx::ParanoidAgent;
+
+ my $ua = LWPx::ParanoidAgent->new;
+
+ # this is 10 seconds overall, from start to finish.  not just between
+ # socket reads.  and it includes all redirects.  so attackers telling
+ # you to download from a malicious tarpit webserver can only stall
+ # you for $n seconds
+
+ $ua->timeout(10);
+
+ # setup extra block lists, in addition to the always-enforced blocking
+ # of private IP addresses, loopbacks, and multicast addresses
+
+ $ua->blocked_hosts(
+    "foo.com",
+    qr/\.internal\.company\.com$/i,
+    sub { my $host = shift;  return 1 if is_bad($host); },
+ );
+
+ $ua->whitelisted_hosts(
+    "brad.lj",
+    qr/^192\.168\.64\.3?/,
+    sub { ... },
+ );
+
+ # get/set the DNS resolver object that's used
+ my $resolver = $ua->resolver;
+ $ua->resolver(Net::DNS::Resolver->new(...));
+
+ # and then just like a normal LWP::UserAgent, because it is one.
+ my $response = $ua->get('http://search.cpan.org/');
+ ...
+ if ($response->is_success) {
+     print $response->content;  # or whatever
+ }
+ else {
+     die $response->status_line;
+ }
+
+=head1 DESCRIPTION
+
+The C<LWPx::ParanoidAgent> is a class subclassing C<LWP::UserAgent>,
+but paranoid against attackers.  It's to be used when you're fetching
+a remote resource on behalf of a possibly malicious user.
+
+This class can do whatever C<LWP::UserAgent> can (callbacks, uploads from
+files, etc), except proxy support is explicitly removed, because in
+that case you should do your paranoia at your proxy.
+
+Also, the schemes are limited to http and https, which are mapped to
+C<LWPx::Protocol::http_paranoid> and
+C<LWPx::Protocol::https_paranoid>, respectively, which are forked
+versions of the same ones without the "_paranoid".  Subclassing them
+didn't look possible, as they were essentially just one huge function.
+
+This class protects you from connecting to internal IP ranges (unless you
+whitelist them), hostnames/IPs that you blacklist, remote webserver
+tarpitting your process (the timeout parameter is changed to be a global
+timeout over the entire process), and all combinations of redirects and
+DNS tricks to otherwise tarpit and/or connect to internal resources.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item C<new>
+
+my $ua = LWPx::ParanoidAgent->new([ %opts ]);
+
+In addition to any constructor options from L<LWP::UserAgent>, you may
+also set C<blocked_hosts> (to an arrayref), C<whitelisted_hosts> (also
+an arrayref), and C<resolver>, a Net::DNS::Resolver object.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $csr->B<resolver>($net_dns_resolver)
+
+=item $csr->B<resolver>
+
+Get/set the L<Net::DNS::Resolver> object used to lookup hostnames.
+
+=item $csr->B<blocked_hosts>(@host_list)
+
+=item $csr->B<blocked_hosts>
+
+Get/set the the list of blocked hosts.  The items in @host_list may be
+compiled regular expressions (with qr//), code blocks, or scalar
+literals.  In any case, the thing that is match, passed in, or
+compared (respectively), is all of the given hostname, given IP
+address, and IP address in canonical a.b.c.d decimal notation.  So if
+you want to block "1.2.3.4" and the user entered it in a mix of
+network/host form in a mix of decimal/octal/hex, you need only block
+"1.2.3.4" and not worry about the details.
+
+=item $csr->B<whitelisted_hosts>(@host_list)
+
+=item $csr->B<whitelisted_hosts>
+
+Like blocked hosts, but matching the hosts/IPs that bypass blocking
+checks.  The only difference is the IP address isn't canonicalized
+before being whitelisted-matched, mostly because it doesn't make sense
+for somebody to enter in a good address in a subversive way.
+
+=back
+
+=head1 SEE ALSO
+
+See L<LWP::UserAgent> to see how to use this class.
+
+=head1 WARRANTY
+
+This module is supplied "as-is" and comes with no warranty, expressed
+or implied.  It tries to protect you from harm, but maybe it will.
+Maybe it will destroy your data and your servers.  You'd better audit
+it and send me bug reports.
+
+=head1 BUGS
+
+Maybe.  See the warranty above.
+
+=head1 COPYRIGHT
+
+Copyright 2005 Brad Fitzpatrick
+
+Lot of code from the the base class, copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.

local/cgi-bin/Net/OpenID/Association.pm

@@ -0,0 +1,231 @@
+use strict;
+use Carp ();
+
+############################################################################
+package Net::OpenID::Association;
+use fields (
+            'server',    # author-identity identity server endpoint
+            'secret',    # the secret for this association
+            'handle',    # the 255-character-max ASCII printable handle (33-126)
+            'expiry',    # unixtime, adjusted, of when this association expires
+            'type',      # association type
+            );
+
+use Storable ();
+use Digest::SHA1 qw(sha1);
+
+sub new {
+    my Net::OpenID::Association $self = shift;
+    $self = fields::new( $self ) unless ref $self;
+    my %opts = @_;
+    for my $f (qw( server secret handle expiry type )) {
+        $self->{$f} = delete $opts{$f};
+    }
+    Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
+    return $self;
+}
+
+sub handle {
+    my $self = shift;
+    die if @_;
+    $self->{'handle'};
+}
+
+sub secret {
+    my $self = shift;
+    die if @_;
+    $self->{'secret'};
+}
+
+sub server {
+    my Net::OpenID::Association $self = shift;
+    Carp::croak("Too many parameters") if @_;
+    return $self->{server};
+}
+
+sub expired {
+    my Net::OpenID::Association $self = shift;
+    return time() > $self->{'expiry'};
+}
+
+sub usable {
+    my Net::OpenID::Association $self = shift;
+    return 0 unless $self->{'handle'} =~ /^[\x21-\x7e]{1,255}$/;
+    return 0 unless $self->{'expiry'} =~ /^\d+$/;
+    return 0 unless $self->{'secret'};
+    return 0 if $self->expired;
+    return 1;
+}
+
+
+# return a handle for an identity server, or undef if
+# no local storage/cache is available, in which case the caller
+# goes into dumb consumer mode.  will do a POST and allocate
+# a new assoc_handle if none is found, or has expired
+sub server_assoc {
+    my ($csr, $server) = @_;
+
+    # closure to return undef (dumb consumer mode) and log why
+    my $dumb = sub {
+        $csr->_debug("server_assoc: dumb mode: $_[0]");
+        return undef;
+    };
+
+    my $cache = $csr->cache;
+    return $dumb->("no_cache") unless $cache;
+
+    # try first from cached association handle
+    if (my $handle = $cache->get("shandle:$server")) {
+        my $assoc = handle_assoc($csr, $server, $handle);
+
+        if ($assoc && $assoc->usable) {
+            $csr->_debug("Found association from cache (handle=$handle)");
+            return $assoc;
+        }
+    }
+
+    # make a new association
+    my $dh = _default_dh();
+
+    my %post = (
+                "openid.mode" => "associate",
+                "openid.assoc_type" => "HMAC-SHA1",
+                "openid.session_type" => "DH-SHA1",
+                "openid.dh_consumer_public" => OpenID::util::bi2arg($dh->pub_key),
+                );
+
+    my $req = HTTP::Request->new(POST => $server);
+    $req->header("Content-Type" => "application/x-www-form-urlencoded");
+    $req->content(join("&", map { "$_=" . OpenID::util::eurl($post{$_}) } keys %post));
+
+    $csr->_debug("Associate mode request: " . $req->content);
+
+    my $ua  = $csr->ua;
+    my $res = $ua->request($req);
+
+    # uh, some failure, let's go into dumb mode?
+    return $dumb->("http_failure_no_associate") unless $res && $res->is_success;
+
+    my $recv_time = time();
+    my $content = $res->content;
+    my %args = OpenID::util::parse_keyvalue($content);
+    $csr->_debug("Response to associate mode: [$content] parsed = " . join(",", %args));
+
+    return $dumb->("unknown_assoc_type") unless $args{'assoc_type'} eq "HMAC-SHA1";
+
+    my $stype = $args{'session_type'};
+    return $dumb->("unknown_session_type") if $stype && $stype ne "DH-SHA1";
+
+    # protocol version 1.1
+    my $expires_in = $args{'expires_in'};
+
+    # protocol version 1.0 (DEPRECATED)
+    if (! $expires_in) {
+        if (my $issued = OpenID::util::w3c_to_time($args{'issued'})) {
+            my $expiry = OpenID::util::w3c_to_time($args{'expiry'});
+            my $replace_after = OpenID::util::w3c_to_time($args{'replace_after'});
+
+            # seconds ahead (positive) or behind (negative) the server is
+            $expires_in = ($replace_after || $expiry) - $issued;
+        }
+    }
+
+    # between 1 second and 2 years
+    return $dumb->("bogus_expires_in") unless $expires_in > 0 && $expires_in < 63072000;
+
+    my $ahandle = $args{'assoc_handle'};
+
+    my $secret;
+    if ($stype ne "DH-SHA1") {
+        $secret = OpenID::util::d64($args{'mac_key'});
+    } else {
+        my $server_pub = OpenID::util::arg2bi($args{'dh_server_public'});
+        my $dh_sec = $dh->compute_secret($server_pub);
+        $secret = OpenID::util::d64($args{'enc_mac_key'}) ^ sha1(OpenID::util::bi2bytes($dh_sec));
+    }
+    return $dumb->("secret_not_20_bytes") unless length($secret) == 20;
+
+    my %assoc = (
+                 handle => $ahandle,
+                 server => $server,
+                 secret => $secret,
+                 type   => $args{'assoc_type'},
+                 expiry => $recv_time + $expires_in,
+                 );
+
+    my $assoc = Net::OpenID::Association->new( %assoc );
+    return $dumb->("assoc_undef") unless $assoc;
+
+    $cache->set("hassoc:$server:$ahandle", Storable::nfreeze(\%assoc));
+    $cache->set("shandle:$server", $ahandle);
+
+    return $assoc;
+}
+
+# returns association, or undef if it can't be found
+sub handle_assoc {
+    my ($csr, $server, $handle) = @_;
+
+    # closure to return undef (dumb consumer mode) and log why
+    my $dumb = sub {
+        $csr->_debug("handle_assoc: dumb mode: $_[0]");
+        return undef;
+    };
+
+    return $dumb->("no_handle") unless $handle;
+
+    my $cache = $csr->cache;
+    return $dumb->("no_cache") unless $cache;
+
+    my $frozen = $cache->get("hassoc:$server:$handle");
+    return $dumb->("not_in_cache") unless $frozen;
+
+    my $param = eval { Storable::thaw($frozen) };
+    return $dumb->("not_a_hashref") unless ref $param eq "HASH";
+
+    return Net::OpenID::Association->new( %$param );
+}
+
+sub invalidate_handle {
+    my ($csr, $server, $handle) = @_;
+    my $cache = $csr->cache
+        or return;
+    $cache->set("hassoc:$server:$handle", "");
+}
+
+sub _default_dh {
+    my $dh = Crypt::DH->new;
+    $dh->p("155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443");
+    $dh->g("2");
+    $dh->generate_keys;
+    return $dh;
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::OpenID::Association - a relationship with an identity server
+
+=head1 DESCRIPTION
+
+Internal class.
+
+=head1 COPYRIGHT, WARRANTY, AUTHOR
+
+See L<Net::OpenID::Consumer> for author, copyrignt and licensing information.
+
+=head1 SEE ALSO
+
+L<Net::OpenID::Consumer>
+
+L<Net::OpenID::VerifiedIdentity>
+
+L<Net::OpenID::Server>
+
+Website:  L<http://www.danga.com/openid/>
+

local/cgi-bin/Net/OpenID/Consumer.pm

@@ -0,0 +1,952 @@
+# LICENSE: You're free to distribute this under the same terms as Perl itself.
+
+use strict;
+use Carp ();
+use LWP::UserAgent;
+use URI::Fetch 0.02;
+
+############################################################################
+package Net::OpenID::Consumer;
+
+use vars qw($VERSION);
+$VERSION = "0.12";
+
+use fields (
+            'cache',           # the Cache object sent to URI::Fetch
+            'ua',              # LWP::UserAgent instance to use
+            'args',            # how to get at your args
+            'consumer_secret', # scalar/subref
+            'required_root',   # the default required_root value, or undef
+            'last_errcode',    # last error code we got
+            'last_errtext',    # last error code we got
+            'debug',           # debug flag or codeblock
+            );
+
+use Net::OpenID::ClaimedIdentity;
+use Net::OpenID::VerifiedIdentity;
+use Net::OpenID::Association;
+
+use MIME::Base64 ();
+use Digest::SHA1 ();
+use Crypt::DH 0.05;
+use Time::Local;
+use HTTP::Request;
+
+sub new {
+    my Net::OpenID::Consumer $self = shift;
+    $self = fields::new( $self ) unless ref $self;
+    my %opts = @_;
+
+    $self->{ua}            = delete $opts{ua};
+    $self->args            ( delete $opts{args}            );
+    $self->cache           ( delete $opts{cache}           );
+    $self->consumer_secret ( delete $opts{consumer_secret} );
+    $self->required_root   ( delete $opts{required_root}   );
+
+    $self->{debug} = delete $opts{debug};
+
+    Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
+    return $self;
+}
+
+sub cache           { &_getset; }
+sub consumer_secret { &_getset; }
+sub required_root   { &_getset; }
+
+sub _getset {
+    my Net::OpenID::Consumer $self = shift;
+    my $param = (caller(1))[3];
+    $param =~ s/.+:://;
+
+    if (@_) {
+        my $val = shift;
+        Carp::croak("Too many parameters") if @_;
+        $self->{$param} = $val;
+    }
+    return $self->{$param};
+}
+
+sub _debug {
+    my Net::OpenID::Consumer $self = shift;
+    return unless $self->{debug};
+
+    if (ref $self->{debug} eq "CODE") {
+        $self->{debug}->($_[0]);
+    } else {
+        print STDERR "[DEBUG Net::OpenID::Consumer] $_[0]\n";
+    }
+}
+
+# given something that can have GET arguments, returns a subref to get them:
+#   Apache
+#   Apache::Request
+#   CGI
+#   HASH of get args
+#   CODE returning get arg, given key
+
+#   ...
+
+sub args {
+    my Net::OpenID::Consumer $self = shift;
+
+    if (my $what = shift) {
+        Carp::croak("Too many parameters") if @_;
+        my $getter;
+        if (! ref $what){
+            Carp::croak("No args defined") unless $self->{args};
+            return $self->{args}->($what);
+        } elsif (ref $what eq "HASH") {
+            $getter = sub { $what->{$_[0]}; };
+        } elsif (ref $what eq "CGI") {
+            $getter = sub { scalar $what->param($_[0]); };
+        } elsif (ref $what eq "Apache") {
+            my %get = $what->args;
+            $getter = sub { $get{$_[0]}; };
+        } elsif (ref $what eq "Apache::Request") {
+            $getter = sub { scalar $what->param($_[0]); };
+        } elsif (ref $what eq "CODE") {
+            $getter = $what;
+        } else {
+            Carp::croak("Unknown parameter type ($what)");
+        }
+        if ($getter) {
+            $self->{args} = $getter;
+        }
+    }
+    $self->{args};
+}
+
+sub ua {
+    my Net::OpenID::Consumer $self = shift;
+    $self->{ua} = shift if @_;
+    Carp::croak("Too many parameters") if @_;
+
+    # make default one on first access
+    unless ($self->{ua}) {
+        my $ua = $self->{ua} = LWP::UserAgent->new;
+        $ua->timeout(10);
+    }
+
+    $self->{ua};
+}
+
+sub _fail {
+    my Net::OpenID::Consumer $self = shift;
+    my ($code, $text) = @_;
+
+    $text ||= {
+        'no_identity_server' => "The provided URL doesn't declare its OpenID identity server.",
+        'empty_url' => "No URL entered.",
+        'bogus_url' => "Invalid URL.",
+        'no_head_tag' => "URL provided doesn't seem to have a head tag.",
+        'url_fetch_err' => "Error fetching the provided URL.",
+    }->{$code};
+
+    $self->{last_errcode} = $code;
+    $self->{last_errtext} = $text;
+
+    $self->_debug("fail($code) $text");
+    wantarray ? () : undef;
+}
+
+sub json_err {
+    my Net::OpenID::Consumer $self = shift;
+    return OpenID::util::js_dumper({
+        err_code => $self->{last_errcode},
+        err_text => $self->{last_errtext},
+    });
+}
+
+sub err {
+    my Net::OpenID::Consumer $self = shift;
+    $self->{last_errcode} . ": " . $self->{last_errtext};
+}
+
+sub errcode {
+    my Net::OpenID::Consumer $self = shift;
+    $self->{last_errcode};
+}
+
+sub errtext {
+    my Net::OpenID::Consumer $self = shift;
+    $self->{last_errtext};
+}
+
+
+sub _get_url_contents {
+    my Net::OpenID::Consumer $self = shift;
+    my  ($url, $final_url_ref, $hook) = @_;
+    $final_url_ref ||= do { my $dummy; \$dummy; };
+
+    my $ures = URI::Fetch->fetch($url,
+                                 UserAgent        => $self->ua,
+                                 Cache            => $self->cache,
+                                 ContentAlterHook => $hook,
+                                 )
+        or return $self->_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr);
+
+    # who actually uses HTTP gone response status?  uh, nobody.
+    if ($ures->status == URI::Fetch::URI_GONE()) {
+        return $self->_fail("url_gone", "URL is no longer available");
+    }
+
+    my $res = $ures->http_response;
+    $$final_url_ref = $res->request->uri->as_string;
+
+    return $ures->content;
+}
+
+sub _find_semantic_info {
+    my Net::OpenID::Consumer $self = shift;
+    my $url = shift;
+    my $final_url_ref = shift;
+
+    my $trim_hook = sub {
+        my $htmlref = shift;
+        # trim everything past the body.  this is in case the user doesn't
+        # have a head document and somebody was able to inject their own
+        # head.  -- brad choate
+        $$htmlref =~ s/<body\b.*//is;
+    };
+
+    my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) or
+        return;
+
+    # find <head> content of document (notably: the first head, if an attacker
+    # has added others somehow)
+    return $self->_fail("no_head_tag", "Couldn't find OpenID servers due to no head tag")
+        unless $doc =~ m!<head[^>]*>(.*?)</head>!is;
+    my $head = $1;
+
+    my $ret = {
+        'openid.server' => undef,
+        'openid.delegate' => undef,
+        'foaf' => undef,
+        'foaf.maker' => undef,
+        'rss' => undef,
+        'atom' => undef,
+    };
+
+    # analyze link/meta tags
+    while ($head =~ m!<(link|meta)\b([^>]+)>!g) {
+        my ($type, $val) = ($1, $2);
+        my $temp;
+
+        # OpenID servers / delegated identities
+        # <link rel="openid.server" href="http://www.livejournal.com/misc/openid.bml" />
+        if ($type eq "link" &&
+            $val =~ /\brel=.openid\.(server|delegate)./i && ($temp = $1) &&
+            $val =~ m!\bhref=[\"\']([^\"\']+)[\"\']!i) {
+            $ret->{"openid.$temp"} = $1;
+            next;
+        }
+
+        # FOAF documents
+        #<link rel="meta" type="application/rdf+xml" title="FOAF" href="http://brad.livejournal.com/data/foaf" />
+        if ($type eq "link" &&
+            $val =~ m!title=.foaf.!i &&
+            $val =~ m!rel=.meta.!i &&
+            $val =~ m!type=.application/rdf\+xml.!i &&
+            $val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
+            $ret->{"foaf"} = $1;
+            next;
+        }
+
+        # FOAF maker info
+        # <meta name="foaf:maker" content="foaf:mbox_sha1sum '4caa1d6f6203d21705a00a7aca86203e82a9cf7a'" />
+        if ($type eq "meta" &&
+            $val =~ m!name=.foaf:maker.!i &&
+            $val =~ m!content=([\'\"])(.*?)\1!i) {
+            $ret->{"foaf.maker"} = $2;
+            next;
+        }
+
+        if ($type eq "meta" &&
+            $val =~ m!name=.foaf:maker.!i &&
+            $val =~ m!content=([\'\"])(.*?)\1!i) {
+            $ret->{"foaf.maker"} = $2;
+            next;
+        }
+
+        # RSS
+        # <link rel="alternate" type="application/rss+xml" title="RSS" href="http://www.livejournal.com/~brad/data/rss" />
+        if ($type eq "link" &&
+            $val =~ m!rel=.alternate.!i &&
+            $val =~ m!type=.application/rss\+xml.!i &&
+            $val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
+            $ret->{"rss"} = $1;
+            next;
+        }
+
+        # Atom
+        # <link rel="alternate" type="application/atom+xml" title="Atom" href="http://www.livejournal.com/~brad/data/rss" />
+        if ($type eq "link" &&
+            $val =~ m!rel=.alternate.!i &&
+            $val =~ m!type=.application/atom\+xml.!i &&
+            $val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
+            $ret->{"atom"} = $1;
+            next;
+        }
+    }
+
+    # map the 4 entities that the spec asks for
+    my $emap = {
+        'lt' => '<',
+        'gt' => '>',
+        'quot' => '"',
+        'amp' => '&',
+    };
+    foreach my $k (keys %$ret) {
+        next unless $ret->{$k};
+        $ret->{$k} =~ s/&(\w+);/$emap->{$1} || ""/eg;
+    }
+
+    $self->_debug("semantic info ($url) = " . join(", ", %$ret));
+
+    return $ret;
+}
+
+sub _find_openid_server {
+    my Net::OpenID::Consumer $self = shift;
+    my $url = shift;
+    my $final_url_ref = shift;
+
+    my $sem_info = $self->_find_semantic_info($url, $final_url_ref) or
+        return;
+
+    return $self->_fail("no_identity_server") unless $sem_info->{"openid.server"};
+    $sem_info->{"openid.server"};
+}
+
+# returns Net::OpenID::ClaimedIdentity
+sub claimed_identity {
+    my Net::OpenID::Consumer $self = shift;
+    my $url = shift;
+    Carp::croak("Too many parameters") if @_;
+
+    # trim whitespace
+    $url =~ s/^\s+//;
+    $url =~ s/\s+$//;
+    return $self->_fail("empty_url", "Empty URL") unless $url;
+
+    # do basic canonicalization
+    $url = "http://$url" if $url && $url !~ m!^\w+://!;
+    return $self->_fail("bogus_url", "Invalid URL") unless $url =~ m!^https?://!i;
+    # add a slash, if none exists
+    $url .= "/" unless $url =~ m!^http://.+/!i;
+
+    my $final_url;
+
+    my $sem_info = $self->_find_semantic_info($url, \$final_url) or
+        return;
+
+    my $id_server = $sem_info->{"openid.server"} or
+        return $self->_fail("no_identity_server");
+
+    return Net::OpenID::ClaimedIdentity->new(
+                                             identity => $final_url,
+                                             server   => $id_server,
+                                             consumer => $self,
+                                             delegate => $sem_info->{'openid.delegate'},
+                                             );
+}
+
+sub user_cancel {
+    my Net::OpenID::Consumer $self = shift;
+    return $self->args("openid.mode") eq "cancel";
+}
+
+sub user_setup_url {
+    my Net::OpenID::Consumer $self = shift;
+    my %opts = @_;
+    my $post_grant = delete $opts{'post_grant'};
+    Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
+    return $self->_fail("bad_mode") unless $self->args("openid.mode") eq "id_res";
+
+    my $setup_url = $self->args("openid.user_setup_url");
+
+    OpenID::util::push_url_arg(\$setup_url, "openid.post_grant", $post_grant)
+        if $setup_url && $post_grant;
+
+    return $setup_url;
+}
+
+sub verified_identity {
+    my Net::OpenID::Consumer $self = shift;
+    my %opts = @_;
+
+    my $rr = delete $opts{'required_root'} || $self->{required_root};
+    Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
+
+    return $self->_fail("bad_mode") unless $self->args("openid.mode") eq "id_res";
+
+    # the asserted identity (the delegated one, if there is one, since the protocol
+    # knows nothing of the original URL)
+    my $a_ident  = $self->args("openid.identity")     or return $self->_fail("no_identity");
+
+    my $sig64    = $self->args("openid.sig")          or return $self->_fail("no_sig");
+    my $returnto = $self->args("openid.return_to")    or return $self->_fail("no_return_to");
+    my $signed   = $self->args("openid.signed");
+
+    my $real_ident = $self->args("oic.identity") || $a_ident;
+
+    # check that returnto is for the right host
+    return $self->_fail("bogus_return_to") if $rr && $returnto !~ /^\Q$rr\E/;
+
+    # check age/signature of return_to
+    my $now = time();
+    {
+        my ($sig_time, $sig) = split(/\-/, $self->args("oic.time") || "");
+        # complain if more than an hour since we sent them off
+        return $self->_fail("time_expired")   if $sig_time < $now - 3600;
+        # also complain if the signature is from the future by more than 30 seconds,
+        # which compensates for potential clock drift between nodes in a web farm.
+        return $self->_fail("time_in_future") if $sig_time - 30 > $now;
+        # and check that the time isn't faked
+        my $c_secret = $self->_get_consumer_secret($sig_time);
+        my $good_sig = substr(OpenID::util::hmac_sha1_hex($sig_time, $c_secret), 0, 20);
+        return $self->_fail("time_bad_sig") unless $sig eq $good_sig;
+    }
+
+    my $final_url;
+    my $sem_info = $self->_find_semantic_info($real_ident, \$final_url);
+    return $self->_fail("unexpected_url_redirect") unless $final_url eq $real_ident;
+
+    my $server = $sem_info->{"openid.server"} or
+        return $self->_fail("no_identity_server");
+
+    # if openid.delegate was used, check that it was done correctly
+    if ($a_ident ne $real_ident) {
+        return $self->_fail("bogus_delegation") unless $sem_info->{"openid.delegate"} eq $a_ident;
+    }
+
+    my $assoc_handle = $self->args("openid.assoc_handle");
+
+    $self->_debug("verified_identity: assoc_handle: $assoc_handle");
+    my $assoc = Net::OpenID::Association::handle_assoc($self, $server, $assoc_handle);
+
+    if ($assoc) {
+        $self->_debug("verified_identity: verifying with found association");
+
+        return $self->_fail("expired_association")
+            if $assoc->expired;
+
+        # verify the token
+        my $token = "";
+        foreach my $p (split(/,/, $signed)) {
+            $token .= "$p:" . $self->args("openid.$p") . "\n";
+        }
+
+        my $good_sig = OpenID::util::b64(OpenID::util::hmac_sha1($token, $assoc->secret));
+        return $self->_fail("signature_mismatch") unless $sig64 eq $good_sig;
+
+    } else {
+        $self->_debug("verified_identity: verifying using HTTP (dumb mode)");
+        # didn't find an association.  have to do dumb consumer mode
+        # and check it with a POST
+        my %post = (
+                    "openid.mode"         => "check_authentication",
+                    "openid.assoc_handle" => $assoc_handle,
+                    "openid.signed"       => $signed,
+                    "openid.sig"          => $sig64,
+                    );
+
+	# and copy in all signed parameters that we don't already have into %post
+	foreach my $param (split(/,/, $signed)) {
+	    next unless $param =~ /^\w+$/;
+	    next if $post{"openid.$param"};
+	    $post{"openid.$param"} = $self->args("openid.$param");
+	}
+
+        # if the server told us our handle as bogus, let's ask in our
+        # check_authentication mode whether that's true
+        if (my $ih = $self->args("openid.invalidate_handle")) {
+            $post{"openid.invalidate_handle"} = $ih;
+        }
+
+        my $req = HTTP::Request->new(POST => $server);
+        $req->header("Content-Type" => "application/x-www-form-urlencoded");
+        $req->content(join("&", map { "$_=" . OpenID::util::eurl($post{$_}) } keys %post));
+
+        my $ua  = $self->ua;
+        my $res = $ua->request($req);
+
+        # uh, some failure, let's go into dumb mode?
+        return $self->_fail("naive_verify_failed_network") unless $res && $res->is_success;
+
+        my $content = $res->content;
+        my %args = OpenID::util::parse_keyvalue($content);
+
+        # delete the handle from our cache
+        if (my $ih = $args{'invalidate_handle'}) {
+            Net::OpenID::Association::invalidate_handle($self, $server, $ih);
+        }
+
+#  bad but works. check out
+#    http://www.livejournal.com/community/lj_everywhere/194480.html?thread=724400#t724400
+#
+        if ($content !~ /error:bad_handle/) {
+          return $self->_fail("naive_verify_failed_return: $content") unless
+  	      $args{'is_valid'} eq "true" ||  # protocol 1.1
+              $args{'lifetime'} > 0;          # DEPRECATED protocol 1.0
+	}
+    }
+
+    $self->_debug("verified identity! = $real_ident");
+
+    # verified!
+    return Net::OpenID::VerifiedIdentity->new(
+                                              identity  => $real_ident,
+                                              foaf      => $sem_info->{"foaf"},
+                                              foafmaker => $sem_info->{"foaf.maker"},
+                                              rss       => $sem_info->{"rss"},
+                                              atom      => $sem_info->{"atom"},
+                                              consumer  => $self,
+                                              );
+}
+
+sub supports_consumer_secret { 1; }
+
+sub _get_consumer_secret {
+    my Net::OpenID::Consumer $self = shift;
+    my $time = shift;
+
+    my $ss;
+    if (ref $self->{consumer_secret} eq "CODE") {
+        $ss = $self->{consumer_secret};
+    } elsif ($self->{consumer_secret}) {
+        $ss = sub { return $self->{consumer_secret}; };
+    } else {
+        Carp::croak("You haven't defined a consumer_secret value or subref.\n");
+    }
+
+    my $sec = $ss->($time);
+    Carp::croak("Consumer secret too long") if length($sec) > 255;
+    return $sec;
+}
+
+package OpenID::util;
+
+# From Digest::HMAC
+sub hmac_sha1_hex {
+    unpack("H*", &hmac_sha1);
+}
+sub hmac_sha1 {
+    hmac($_[0], $_[1], \&Digest::SHA1::sha1, 64);
+}
+sub hmac {
+    my($data, $key, $hash_func, $block_size) = @_;
+    $block_size ||= 64;
+    $key = &$hash_func($key) if length($key) > $block_size;
+
+    my $k_ipad = $key ^ (chr(0x36) x $block_size);
+    my $k_opad = $key ^ (chr(0x5c) x $block_size);
+
+    &$hash_func($k_opad, &$hash_func($k_ipad, $data));
+}
+
+sub parse_keyvalue {
+    my $reply = shift;
+    my %ret;
+    $reply =~ s/\r//g;
+    foreach (split /\n/, $reply) {
+        next unless /^(\S+?):(.*)/;
+        $ret{$1} = $2;
+    }
+    return %ret;
+}
+
+sub ejs
+{
+    my $a = $_[0];
+    $a =~ s/[\"\'\\]/\\$&/g;
+    $a =~ s/\r?\n/\\n/gs;
+    $a =~ s/\r//;
+    return $a;
+}
+
+# Data::Dumper for JavaScript
+sub js_dumper {
+    my $obj = shift;
+    if (ref $obj eq "HASH") {
+        my $ret = "{";
+        foreach my $k (keys %$obj) {
+            $ret .= "$k: " . js_dumper($obj->{$k}) . ",";
+        }
+        chop $ret;
+        $ret .= "}";
+        return $ret;
+    } elsif (ref $obj eq "ARRAY") {
+        my $ret = "[" . join(", ", map { js_dumper($_) } @$obj) . "]";
+        return $ret;
+    } else {
+        return $obj if $obj =~ /^\d+$/;
+        return "\"" . ejs($obj) . "\"";
+    }
+}
+
+sub eurl
+{
+    my $a = $_[0];
+    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
+    $a =~ tr/ /+/;
+    return $a;
+}
+
+sub push_url_arg {
+    my $uref = shift;
+    $$uref =~ s/[&?]$//;
+    my $got_qmark = ($$uref =~ /\?/);
+
+    while (@_) {
+        my $key = shift;
+        my $value = shift;
+        $$uref .= $got_qmark ? "&" : ($got_qmark = 1, "?");
+        $$uref .= eurl($key) . "=" . eurl($value);
+    }
+}
+
+sub time_to_w3c {
+    my $time = shift || time();
+    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
+    $mon++;
+    $year += 1900;
+
+    return sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
+                   $year, $mon, $mday,
+                   $hour, $min, $sec);
+}
+
+sub w3c_to_time {
+    my $hms = shift;
+    return 0 unless
+        $hms =~ /^(\d{4,4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/;
+
+    my $time;
+    eval {
+        $time = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1);
+    };
+    return 0 if $@;
+    return $time;
+}
+
+sub bi2bytes {
+    my $bigint = shift;
+    die "Can't deal with negative numbers" if $bigint->is_negative;
+
+    my $bits = $bigint->as_bin;
+    die unless $bits =~ s/^0b//;
+
+    # prepend zeros to round to byte boundary, or to unset high bit
+    my $prepend = (8 - length($bits) % 8) || ($bits =~ /^1/ ? 8 : 0);
+    $bits = ("0" x $prepend) . $bits if $prepend;
+
+    return pack("B*", $bits);
+}
+
+sub bi2arg {
+    return b64(bi2bytes($_[0]));
+}
+
+sub b64 {
+    my $val = MIME::Base64::encode_base64($_[0]);
+    $val =~ s/\s+//g;
+    return $val;
+}
+
+sub d64 {
+    return MIME::Base64::decode_base64($_[0]);
+}
+
+sub bytes2bi {
+    return Math::BigInt->new("0b" . unpack("B*", $_[0]));
+}
+
+sub arg2bi {
+    return undef unless defined $_[0] and $_[0] ne "";
+    # don't acccept base-64 encoded numbers over 700 bytes.  which means
+    # those over 4200 bits.
+    return Math::BigInt->new("0") if length($_[0]) > 700;
+    return bytes2bi(MIME::Base64::decode_base64($_[0]));
+}
+
+
+__END__
+
+=head1 NAME
+
+Net::OpenID::Consumer - library for consumers of OpenID identities
+
+=head1 SYNOPSIS
+
+  use Net::OpenID::Consumer;
+
+  my $csr = Net::OpenID::Consumer->new(
+    ua    => LWPx::ParanoidAgent->new,
+    cache => Some::Cache->new,
+    args  => $cgi,
+    consumer_secret => ...,
+    required_root => "http://site.example.com/",
+  );
+
+  # a user entered, say, "bradfitz.com" as their identity.  The first
+  # step is to fetch that page, parse it, and get a
+  # Net::OpenID::ClaimedIdentity object:
+
+  my $claimed_identity = $csr->claimed_identity("bradfitz.com");
+
+  # now your app has to send them at their identity server's endpoint
+  # to get redirected to either a positive assertion that they own
+  # that identity, or where they need to go to login/setup trust/etc.
+
+  my $check_url = $claimed_identity->check_url(
+    return_to  => "http://example.com/openid-check.app?yourarg=val",
+    trust_root => "http://example.com/",
+  );
+
+  # so you send the user off there, and then they come back to
+  # openid-check.app, then you see what the identity server said;
+
+  if (my $setup_url = $csr->user_setup_url) {
+       # redirect/link/popup user to $setup_url
+  } elsif ($csr->user_cancel) {
+       # restore web app state to prior to check_url
+  } elsif (my $vident = $csr->verified_identity) {
+       my $verified_url = $vident->url;
+       print "You are $verified_url !";
+  } else {
+       die "Error validating identity: " . $csr->err;
+  }
+
+
+=head1 DESCRIPTION
+
+This is the Perl API for (the consumer half of) OpenID, a distributed
+identity system based on proving you own a URL, which is then your
+identity.  More information is available at:
+
+  http://www.danga.com/openid/
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item C<new>
+
+my $csr = Net::OpenID::Consumer->new([ %opts ]);
+
+You can set the C<ua>, C<cache>, C<consumer_secret>, C<required_root>,
+and C<args> in the constructor.  See the corresponding method
+descriptions below.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $csr->B<ua>($user_agent)
+
+=item $csr->B<ua>
+
+Getter/setter for the LWP::UserAgent (or subclass) instance which will
+be used when web donwloads are needed.  It's highly recommended that
+you use LWPx::ParanoidAgent, or at least read its documentation so
+you're aware of why you should care.
+
+=item $csr->B<cache>($cache)
+
+=item $csr->B<cache>
+
+Getter/setter for the optional (but recommended!) cache instance you
+want to use for storing fetched parts of pages.  (identity server
+public keys, and the E<lt>headE<gt> section of user's HTML pages)
+
+The $cache object can be anything that has a -E<gt>get($key) and
+-E<gt>set($key,$value) methods.  See L<URI::Fetch> for more
+information.  This cache object is just passed to L<URI::Fetch>
+directly.
+
+=item $nos->B<consumer_secret>($scalar)
+
+=item $nos->B<consumer_secret>($code)
+
+=item $code = $nos->B<consumer_secret>; ($secret) = $code->($time);
+
+The consumer secret is used to generate self-signed nonces for the
+return_to URL, to prevent spoofing.
+
+In the simplest (and least secure) form, you configure a static secret
+value with a scalar.  If you use this method and change the scalar
+value, any outstanding requests from the last 30 seconds or so will fail.
+
+The more robust (but more complicated) form is to supply a subref that
+returns a secret based on the provided I<$time>, a unix timestamp.
+And if one doesn't exist for that time, create, store and return it
+(with appropriate locking so you never return different secrets for
+the same time.)
+
+Your secret may not exceed 255 characters.
+
+=item $csr->B<args>($ref)
+
+=item $csr->B<args>($param)
+
+=item $csr->B<args>
+
+Can be used in 1 of 3 ways:
+
+1. Setting the way which the Consumer instances obtains GET parameters:
+
+$csr->args( $reference )
+
+Where $reference is either a HASH ref, CODE ref, Apache $r,
+Apache::Request $apreq, or CGI.pm $cgi.  If a CODE ref, the subref
+must return the value given one argument (the parameter to retrieve)
+
+2. Get a paramater:
+
+my $foo = $csr->args("foo");
+
+When given an unblessed scalar, it retrieves the value.  It croaks if
+you haven't defined a way to get at the parameters.
+
+3. Get the getter:
+
+my $code = $csr->args;
+
+Without arguments, returns a subref that returns the value given a
+parameter name.
+
+=item $nos->B<required_root>($url_prefix)
+
+=item $url_prefix = $nos->B<required_root>
+
+If provided, this is the required string that all return_to URLs must
+start with.  If it doesn't match, it'll be considered invalid (spoofed
+from another site)
+
+=item $csr->B<claimed_identity>($url)
+
+Given a user-entered $url (which could be missing http://, or have
+extra whitespace, etc), returns either a Net::OpenID::ClaimedIdentity
+object, or undef on failure.
+
+Note that this identity is NOT verified yet.  It's only who the user
+claims they are, but they could be lying.
+
+If this method returns undef, you can rely on the following errors
+codes (from $csr->B<errcode>) to decide what to present to the user:
+
+=over 8
+
+=item no_identity_server
+
+=item empty_url
+
+=item bogus_url
+
+=item no_head_tag
+
+=item url_fetch_err
+
+=back
+
+
+=item $csr->B<user_setup_url>( [ %opts ] )
+
+Returns the URL the user must return to in order to login, setup trust,
+or do whatever the identity server needs them to do in order to make
+the identity assertion which they previously initiated by entering
+their claimed identity URL.  Returns undef if this setup URL isn't
+required, in which case you should ask for the verified_identity.
+
+The base URL this this function returns can be modified by using the
+following options in %opts:
+
+=over
+
+=item C<post_grant>
+
+What you're asking the identity server to do with the user after they
+setup trust.  Can be either C<return> or C<close> to return the user
+back to the return_to URL, or close the browser window with
+JavaScript.  If you don't specify, the behavior is undefined (probably
+the user gets a dead-end page with a link back to the return_to URL).
+In any case, the identity server can do whatever it wants, so don't
+depend on this.
+
+=back
+
+=item $csr->B<user_cancel>
+
+Returns true if the user declined to share their identity, false
+otherwise.  (This function is literally one line: returns true if
+"openid.mode" eq "cancel")
+
+It's then your job to restore your app to where it was prior to
+redirecting them off to the user_setup_url, using the other query
+parameters that you'd sent along in your return_to URL.
+
+=item $csr->B<verified_identity>( [ %opts ] )
+
+Returns a Net::OpenID::VerifiedIdentity object, or undef.
+Verification includes double-checking the reported identity URL
+declares the identity server, verifying the signature, etc.
+
+The options in %opts may contain:
+
+=over
+
+=item C<required_root>
+
+Sets the required_root just for this request.  Values returns to its
+previous value afterwards.
+
+=back
+
+=item $csr->B<err>
+
+Returns the last error, in form "errcode: errtext"
+
+=item $csr->B<errcode>
+
+Returns the last error code.
+
+=item $csr->B<errtext>
+
+Returns the last error text.
+
+=item $csr->B<json_err>
+
+Returns the last error code/text in JSON format.
+
+=back
+
+=head1 COPYRIGHT
+
+This module is Copyright (c) 2005 Brad Fitzpatrick.
+All rights reserved.
+
+You may distribute under the terms of either the GNU General Public
+License or the Artistic License, as specified in the Perl README file.
+If you need more liberal licensing terms, please contact the
+maintainer.
+
+=head1 WARRANTY
+
+This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
+
+=head1 SEE ALSO
+
+OpenID website:  http://www.danga.com/openid/
+
+L<Net::OpenID::ClaimedIdentity> -- part of this module
+
+L<Net::OpenID::VerifiedIdentity> -- part of this module
+
+L<Net::OpenID::Server> -- another module, for acting like an OpenID server
+
+=head1 AUTHORS
+
+Brad Fitzpatrick <brad@danga.com>

local/cgi-bin/bml/scheme/added.variables

@@ -0,0 +1,32 @@
+ljrlook.nav.create
+ljrlook.nav.update
+ljrlook.nav.fullupdate
+ljrlook.nav.site
+ljrlook.nav.news
+ljrlook.nav.paidaccounts
+ljrlook.nav.edit
+ljrlook.nav.modify
+ljrlook.nav.editinfo
+ljrlook.nav.editfriends
+ljrlook.nav.editjournal
+ljrlook.nav.editpics
+ljrlook.nav.changepassword
+ljrlook.nav.communities.manage
+ljrlook.nav.frills
+ljrlook.nav.customize
+ljrlook.nav.createstyle
+ljrlook.nav.editstyle
+ljrlook.nav.needhelp
+ljrlook.nav.lostinfo
+ljrlook.nav.support.faq
+ljrlook.nav.support
+
+ljrlook.nav.hello
+ljrlook.nav.yourjournal
+ljrlook.nav.recent
+ljrlook.nav.calendar
+ljrlook.nav.friends
+ljrlook.nav.userinfo
+ljrlook.nav.memories
+ljrlook.nav.logout
+ljrlook.nav.login

local/cgi-bin/bml/scheme/bluewhite.look

@@ -0,0 +1,267 @@
+#
+# Welcome to GENERIC.LOOK for the WhiteBlue scheme
+#
+# by....
+# 	Brad Fitzpatrick
+# 	brad@danga.com
+#
+
+######################### little stuff
+
+_parent=>global.look
+
+AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+
+H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+
+H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+GRIN=>&lt;grin&gt;
+HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
+
+NEWLINE=>{D}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<BR>%%DATA%%
+P/FOLLOW_P=>{D}<BR><IMG SRC="/img/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
+
+STANDOUTO<=
+{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
+BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
+%%DATA%%
+
+</TD></TR></TABLE></CENTER>
+<=STANDOUTO
+
+STANDOUT<=
+{D}<CENTER><FONT SIZE=1><BR></FONT>
+<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
+ <tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="/img/corn_nw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="/img/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="/img/corn_ne.gif" alt=""></td>
+ </tr><tr>
+  <td width=7>
+   <img width=7 height=1 src="/img/dot.gif" alt=""></td>
+  <td valign=top>
+%%DATA%%
+
+  </td>
+  <td width=7>
+   <img width=7 height=1 src="/img/dot.gif" alt=""></td>
+ </tr><tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="/img/corn_sw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="/img/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="/img/corn_se.gif" alt=""></td>
+ </tr>
+</table>
+
+</CENTER>
+<=STANDOUT
+SOERROR=><div style='background-color:#f3f4fe; color:red; font-weight:bold; text-align:center'>%%data%%</div>
+EMAILEX=><div style='width: 50%; font-family: courier; background-color: #efefef; border: dotted #cdcdcd 2px; padding: 5px;'>%%data%%</div>
+
+######################### choices stuff
+
+CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
+
+CHOICES<=
+{F}<P><DIV CLASS="choice"><TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
+<TR>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMS%%
+</DL>
+</TD>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMSB%%
+</DL>
+</TD>
+</TR>
+</TABLE></DIV>
+<=CHOICES
+
+##################################################################################
+################################### MAIN PAGE ####################################
+##################################################################################
+
+PAGE<=
+{Fps}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<HTML><?load_page_info?>
+<HEAD>
+<title><?_code {
+    my $elhash = $_[2];
+    return $elhash->{'WINDOWTITLE'} || $elhash->{'TITLE'};
+} _code?></title>
+%%head%%
+<?_code
+    use strict;
+    my $crumb_up;
+    if(LJ::get_active_crumb() ne '')
+    {
+        my $parentcrumb = LJ::get_parent_crumb();
+        $crumb_up = "<link rel='up' title='$parentcrumb->[0]' href='$parentcrumb->[1]' />";
+    }
+    return $crumb_up;
+_code?>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF TOPMARGIN="0" LEFTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0" LINK=#0000C0 VLINK=#600060 %%bodyopts%%>
+
+<TABLE WIDTH=100% BORDER=0 CELLPADDING=0 CELLSPACING=0 BACKGROUND="/img/bluewhite/bluefade.jpg">
+<TR WIDTH=100%>
+<TD VALIGN=BOTTOM ALIGN=LEFT HEIGHT=100>
+
+   <TABLE BACKGROUND="" HEIGHT=95 WIDTH=100% BORDER=0>
+      <TR>
+        <TD WIDTH=3>&nbsp;</TD>
+        <TD HEIGHT=53 WIDTH=406 VALIGN=BOTTOM>
+<?_code
+$is_home = (BML::get_uri() =~ m!^/(index\.bml)?!);
+if (0 && $is_home)
+{
+	return '<IMG SRC="/img/bluewhite/title.gif" WIDTH=600 HEIGHT=53><!-- ';
+}
+return "";
+_code?>
+
+<FONT SIZE=6 COLOR="#000a3f" FACE="Arial, Helvetica"><B>%%TITLE%%</B></FONT>
+
+<?_code
+if (0 && $is_home)
+{
+	return ' -->';
+}
+return "";
+_code?>
+
+      </TD>
+      <TD VALIGN=TOP ALIGN=RIGHT>
+<?_code
+ unless ($is_home) {
+     return "<A HREF=\"/\"><IMG SRC=\"/img/bluewhite/home.gif\" WIDTH=35 HEIGHT=36 BORDER=0></A>&nbsp;";
+ }
+ return "";
+_code?>
+      </TD>
+    </TR>
+    </TABLE>
+
+</TD></TR>
+<TR><TD bgcolor="#FFFFFF"><?breadcrumbs?></TD></TR>
+</TABLE>
+
+<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>
+<TR VALIGN=TOP>
+<TD WIDTH=155 BGCOLOR=#d7d9e8 NOWRAP><IMG SRC="/img/bluewhite/hline.gif" WIDTH=155 HEIGHT=25 ALT="">
+
+<TABLE WIDTH=153 BORDER=0 CELLSPACING=0 CELLPADDING=0>
+<TR><TD>
+
+<FONT FACE="Arial,Helvetica" SIZE=-1>
+<?_code
+
+ $ret = "";
+
+ sub dump_entry 
+ {
+     my ($ret, $listref, $depth) = @_;
+
+     foreach my $mi (@$listref) 
+     {
+	 if ($depth==0) { 
+	     $$ret .= "<P><IMG SRC=\"/img/bluewhite/bullet.gif\" WIDTH=10 HEIGHT=10 HSPACE=2 ALIGN=ABSMIDDLE>";
+	 } else {
+	     $$ret .= "&nbsp;" x ($depth*3+1);
+	     $$ret .= $mi->{'cont'} ? "&nbsp;&nbsp;" : "- ";
+	 }
+
+	 my $name = $mi->{'name'};
+	 $name =~ s/ /&nbsp;/g;
+	 if (! defined $mi->{'uri'}) {
+	     if ($depth == 0) {
+		 $$ret .= "<B>$name</B><BR>";
+	     } else {
+		 $$ret .= "$name<BR>";
+	     }
+	 } elsif ($mi->{'match'} ? 
+		  (BML::get_uri() =~ /$mi->{'match'}/) :
+		  (BML::get_uri() eq $mi->{'uri'})
+		  ){
+	     $$ret .= "<B><SPAN style=\"background-color: #FFFFFF\"><FONT COLOR=#0000D0>$name</FONT></SPAN></B><BR>";
+	 } else {
+	     $$ret .= "<A HREF=\"$mi->{'uri'}\">$name</A><BR>";
+	 }
+
+	 if ($mi->{'children'} && 
+	     ($mi->{'recursematch'} ? BML::get_uri() =~ /$mi->{'recursematch'}/ : 1)) {
+	     &dump_entry($ret, $mi->{'children'}, $depth+1);
+	 }
+     }
+     
+ }
+
+&dump_entry(\$ret, \@sidebar, 0);
+
+ return $ret;
+
+_code?>
+</FONT>
+
+</TD></TR></TABLE>
+</TD>
+<TD ALIGN=LEFT BACKGROUND="/img/bluewhite/vline.gif" WIDTH=25 NOWRAP>
+   <IMG SRC="/img/bluewhite/linetop.gif" WIDTH=25 HEIGHT=25 ALT=""><BR>
+   <IMG SRC="/img/bluewhite/vline.gif" WIDTH=25 HEIGHT=800 ALT="">
+</TD>
+<TD>
+
+<IMG SRC="/img/dot.gif" WIDTH=1 HEIGHT=3><BR>
+%%BODY%%
+
+</TD>
+<TD WIDTH=20>&nbsp;</TD>
+</TR>
+
+<!-- table closure row -->
+<TR>
+<TD WIDTH=155 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade.gif" WIDTH=155 HEIGHT=25 ALT=""></TD>
+<TD WIDTH=25 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade_line.gif" WIDTH=25 HEIGHT=25 ALT=""></TD></TD>
+<TD>
+&nbsp;
+</TD>
+<TD WIDTH=20>&nbsp;</TD>
+</TR>
+</TABLE>
+<!-- /table closure row -->
+
+<!--<TABLE WIDTH=100%>
+<TR>
+<TD ALIGN=RIGHT>
+	<FONT FACE="Arial, Helvetica" SIZE="-2">
+		<A HREF="/privacy.bml">Privacy Policy</A> - 
+		<A HREF="/coppa.bml">COPPA</A><BR>
+		<A HREF="/disclaimer.bml">Legal Disclaimer</A> - 
+		<A HREF="/sitemap.bml">Site Map</A><BR>
+	</FONT>
+</TD>
+</TR>
+</TABLE>
+-->
+
+</BODY>
+</HTML>
+<=PAGE
+

local/cgi-bin/bml/scheme/dystopia.look

@@ -0,0 +1,622 @@
+# LiveJournal.com-specific library 
+#
+# This file is NOT licensed under the GPL.  As with everything in the
+# "ljcom" CVS repository, this file is the property of Danga
+# Interactive and is made available to the public only as a reference 
+# as to the best way to modify/extend the base LiveJournal server code
+# (which is licensed under the GPL).
+#
+# Feel free to read and learn from things in "ljcom", but don't use
+# our schemes because we don't want your site looking like
+# LiveJournal.com (our logo and site scheme are our identity and we
+# don't want to confuse users)
+#
+# Instead, use/modify one of the schemes in the "livejournal" repository.
+# (Ideally you'd make your own entirely)
+#
+
+_parent=>global.look
+
+help=>{Ds}<a href="%%data%%"><img src="<?imgprefix?>/help.gif" alt="(<?_ml Help _ml?>)" title="(<?_ml Help _ml?>)" width='14' height='14' hspace='2' align='absmiddle' border='0'></a>
+
+h1=>{D}<p><span class="heading">%%data%%</span>
+h1/follow_choices=>{D}<span class="heading">%%data%%</span>
+
+h2=>{D}<p><span class="heading2">%%data%%</span>
+
+# Banner Header: search results banner, content desriptor, etc...
+bh=>{D}<p align="center"><font face="Arial,Helvetica" color="#cc0000" size="-1"><b>%%data%%</b></font>
+
+grin=>{S}&lt;grin&gt;
+hr=>{S}<p align="center"><font color=#660066>*</font></p>
+
+newline=>{S}<br />&nbsp;&nbsp;&nbsp;&nbsp;
+p=>{DRp}<br />%%data%%
+p/follow_p=>{DRps}<br /><img src="<?imgprefix?>/dot.gif" width="1" vspace="6" height="1"><br />%%data%%
+
+emcolor=>{S}#a7c7e8
+emcolorlite=>{S}#d9e9f9
+altcolor1=>{S}#d9e9f9
+altcolor2=>{S}#a7c7e8
+
+de=>{DRp}<span style="color:#909090;">%%data%%</span>
+
+standout<=
+{DRps}<center><font size="1"><br /></font>
+<table cellspacing="0" cellpadding="0" border="0" bgcolor="<?emcolor?>">
+ <tr align="left">
+  <td width="7" align="left" valign="top">
+   <img width="7" height="7" src="<?imgprefix?>/dys/corn_nw.gif" alt="/"></td>
+  <td height="7">
+   <img height="7" src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td width="7" valign="top" align="right">
+   <img height="7" src="<?imgprefix?>/dys/corn_ne.gif" alt="\"></td>
+ </tr><tr align="left">
+  <td width="7">
+   <img width="7" height="1" src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td valign="top">
+%%data%%
+
+  </td>
+  <td width="7">
+   <img width="7" height="1" src="<?imgprefix?>/dot.gif" alt=""></td>
+ </tr><tr>
+  <td width="7" align=left valign=top>
+   <img width="7" height="7" src="<?imgprefix?>/dys/corn_sw.gif" alt="\"></td>
+  <td height="7">
+   <img height="7" src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td width="7" valign=top align=right>
+   <img height="7" src="<?imgprefix?>/dys/corn_se.gif" alt="/"></td>
+ </tr>
+</table>
+
+</center>
+<=standout
+
+warningbar<=
+{DRps}<div class="warningbar" style="background-image: URL('<?imgprefix?>/message-warning.gif');">
+%%data%%
+</div>
+<=warningbar
+
+errorbar<=
+{DRps}<div class="errorbar" style="background-image: URL('<?imgprefix?>/message-error.gif');">
+%%data%%
+</div>
+<=errorbar
+
+soerror=><div style='background-color:#d0eef9; color:red; font-weight:bold; text-align:center'>%%data%%</div>
+emailex=><div style='width: 50%; font-family: courier; background-color: #efefef; border: dotted #cdcdcd 2px; padding: 5px;'>%%data%%</div>
+
+######################### choices stuff
+
+choice=>{PRps}<dt><img src="<?imgprefix?>/dys/b_purp.gif" align="absmiddle" width="8" height="8"> <a href="%%data2%%"><font face="Arial,Helvetica"><b>%%data1%%</b></font></a><dd><font size="2">%%data3%%</font>
+
+choices<=
+{FRp}<p><div class="choice"><table width="100%" cellpadding="2" cellspacing="5">
+<tr>
+<td valign="top" width="50%">
+<dl>
+%%items%%
+</dl>
+</td>
+<td valign="top" width="50%">
+<dl>
+%%itemsb%%
+</dl>
+</td>
+</tr>
+</table></div>
+<=choices
+
+ENTRYFORMCSS<=
+{Ss}
+<style type="text/css">
+#EntryForm #MetaInfo {
+    width: 100%;
+}
+#EntryForm th {
+    font-size: .85em;
+}
+#EntryForm #SubmitBar {
+    background-color: #dfdfdf;
+    padding: 5px;
+    text-align: center;
+    border: 1px outset #000;
+    margin-left: auto; margin-right: auto;
+}
+#MetaInfo tr {
+    padding-bottom: 10px;
+}
+#metainfo th { 
+    text-align: left; 
+}
+#mood_preview {
+    display: none;
+}
+#datetime_box input, #datetime_box select {
+    margin-right: 2px;
+}
+#EntryForm legend {
+    font-weight: bold;
+}
+#EntryForm #Options {
+    margin-left: 0; margin-right: 0; padding: 0;
+    background-color: #dfdfdf;
+    border: 1px outset #000;
+}
+#EntryForm #Options th {
+    text-align: left;
+}
+#EntryForm #infobox {
+    text-align: center;
+}
+#EntryForm #infobox table {
+    background-color: #dfdfdf;
+    border: 2px solid <?emcolor?>;
+}
+#EntryForm textarea {
+    border: 1px inset #000;
+    padding: 2px;
+}
+#EntryForm #Security option {
+    padding-left: 18px;
+}
+#EntryForm #security_public {
+    background-image: url("<?imgprefix?>/userinfo.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_private {
+    background-image: url("<?imgprefix?>/icon_private.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_friends, #EntryForm #security_custom {
+    background-image: url("<?imgprefix?>/icon_protected.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #UserpicPreviewImage {
+    border: 1px solid #000;
+}
+#EntryForm {
+    width: 100%;
+}
+</style>
+<=ENTRYFORMCSS
+
+##################################################################################
+################################### MAIN PAGE ####################################
+##################################################################################
+
+PAGE<=
+{Fps}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<html>
+<?_code
+{
+    my $remote = LJ::get_remote(); # will be requested later and returned from cache
+    return LJ::LJcom::expresslane_html_comment($remote, $_[0]->{r});
+}
+_code?>
+<head>
+<link rel="SHORTCUT ICON" href="<?siteroot?>/favicon.ico">
+<link rel="home" title="Home" href="/" />
+<link rel="contents" title="Site Map" href="/site/" />
+<link rel="help" title="Technical Support" href="/support/" />
+<title><?_code {
+    my $elhash = $_[2];
+    return $elhash->{'WINDOWTITLE'} || $elhash->{'TITLE'};
+} _code?></title>
+<?metactype?>
+<style type="text/css">
+<!--
+p, td { font-size: 12px; font-family: Verdana, Arial, Helvetica, sans-serif; }
+li { font-size: 12px; font-family: Verdana, Arial, Helvetica, sans-serif; }
+body { font-size: 12px; font-family: Verdana, Arial, Helvetica, sans-serif; margin: 0px; }
+.navtext {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #FF9900; font-weight: bold}
+.navlinks {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #FFFFFF; text-decoration: underline}
+a:link {  font-family: Verdana, Arial, Helvetica, sans-serif; color: #000066; }
+a:visited {  font-family: Verdana, Arial, Helvetica, sans-serif; color: #000066; }
+a:active {  font-family: Verdana, Arial, Helvetica, sans-serif; color: #006699; }
+.wtext {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; font-weight: bold; color: #FFFFFF}
+.login {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px}
+.wtextunbld { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #FFFFFF }
+.copy { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #000000}
+.heading {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 13px; color: #660066; font-weight: bold}
+.heading2 {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 13px; color: #660066; font-style: italic }
+.talk-comment { margin-top: 1em; }
+.lesstop { margin-top: 2px; }
+.formitem { color: #343434; font-size: 1em; }
+.formnumber { font-weight: bold; margin-top: 1.8em; font-size: .9em; }
+.formitemName { font-weight: bold; font-size: .9em; margin-top: 1.8em; }
+.formitemDesc { margin-top: .4em; margin-bottom: .4em; color: #505050; }
+.formitemNote { color: #da6320; font-size: .9em; margin-top: .4em; margin-bottom: .4em; }
+.formitemFlag { color: #CE0000; font-size: .9em; margin-top: .4em; margin-bottom: .4em; }
+.borderedtable { border: solid 1px black; }
+.borderedtable th { background-color: #dddddd; border-bottom: solid 1px black; padding-left: 10px; padding-right: 10px; white-space: nowrap; font-size: 0.8em; }
+
+#Comments q { padding-left: 2.5em; font-style: italic; }
+
+.errorbar {
+    color: #000;
+    font: 12px Verdana, Arial, Sans-Serif;
+    background-color: #FFEEEE;
+    background-repeat: repeat-x;
+    border: 1px solid #FF9999;
+    padding: 8px;
+    margin-top: auto; margin-bottom: auto;
+    margin-left: auto; margin-right: auto;
+    width: auto;
+    text-align: left;
+}
+.warningbar {
+    color: #000;
+    font: 12px Verdana, Arial, Sans-Serif;
+    background-color: #FFFFDD;
+    background-repeat: repeat-x;
+    border: 1px solid #FFCC33;
+    padding: 8px;
+    margin-top: auto; margin-bottom: auto;
+    margin-left: auto; margin-right: auto;
+    width: auto;
+    text-align: left;
+}
+-->
+</style>
+
+<script language="JavaScript">
+  window.onerror = null;  // damn javascript.
+</script>
+<?_code return (! LJ::get_remote() &&
+                ! $LJ::IS_SSL &&
+                ! $LJ::REQ_HEAD_HAS{'chalresp_js'}++) ?
+                $LJ::COMMON_CODE{'chalresp_js'} : "";
+_code?>
+<?_code
+    use strict;
+    my $crumb_up;
+    if(LJ::get_active_crumb() ne '')
+    {
+        my $parentcrumb = LJ::get_parent_crumb();
+        $crumb_up = "<link rel='up' title='$parentcrumb->[0]' href='$parentcrumb->[1]' />";
+    }
+    return $crumb_up;
+_code?>
+%%head%%
+</head>
+<body bgcolor="#FFFFFF" background="<?imgprefix?>/dys/bg.gif" leftmargin="0" topmargin="0" marginwidth="0" marginheight="0" text="#000000" link="#660066" vlink="#000066" alink="#CC6600" %%bodyopts%%>
+<basefont face="Verdana,Arial,Helvetica">
+<table width="100%" border="0" cellspacing="0" cellpadding="0">
+  <tr align="left" valign="top">
+	<td  colspan='2'>
+            <table width='100%' border="0" cellspacing="0" cellpadding="0" background="<?imgprefix?>/dys/bg_top.gif">
+		<tr>
+                  <td><a href="<?siteroot?>/"><img src="<?imgprefix?>/dys/logo1.gif" width="122" height="51" border="0"></a></td>
+		  <td width="163" align="left" valign="top"><a href="<?siteroot?>/"><img src="<?imgprefix?>/dys/logo2.gif" width="170" height="51" border="0"></a></td>
+		  <td background="<?imgprefix?>/dys/bg_top.gif" align="left" valign="top" width="244">&nbsp;</td>
+		  <td background="<?imgprefix?>/dys/bg_top.gif" align="left" valign="top" width="100%">&nbsp;</td>
+		</tr>
+	  </table>
+	</td>
+  </tr>
+
+<!-- logo, then search & logged in links bar stack on top of each other -->
+
+  <tr align="left" valign="top">
+	<td width="<?_ml dystopia.nav.width _ml?>" height="49"
+><?_code
+  unless ($BML::COOKIE{'langpref'}) {
+      return '<img src="<?imgprefix?>/dys/logo3-lang.gif" width="122" height="52" border="0" ismap="ismap" usemap="#setlang"><map name="setlang"><area href="/manage/siteopts.bml" shape="rect" coords="50,25,122,50"></map>';
+  } else {
+      return '<img src="<?imgprefix?>/dys/logo3.gif" width="122" height="52" border="0">';
+  }
+_code?></td>
+  <td height="49">
+  <table width="100%" border="0" cellspacing="0" cellpadding="0">
+  <colgroup span="3">
+  <col width="19%" />
+  <col width="34%" />
+  <col width="47%" />
+  </colgroup>
+
+<!-- search bar -->
+		<tr valign="top">
+		  <td height="24" width="19%" align="left">&nbsp;</td>
+                  <form action="/multisearch.bml">
+		  <td height="24" align="right" valign="middle" colspan="2" nowrap="nowrap">
+<font face="verdana, arial, sans-serif" color=#333333 size=-2>
+			<span class="wtextunbld"><label for='searchlj'><?_ml dystopia.searchlj _ml?></label>&nbsp;</span>
+<?_code
+#BML:cache
+ my $ret;
+ my ($cur, $val) = ("user", "");
+ my ($uri, $args) = (BML::get_uri(), BML::get_query_string());
+ if ($uri eq '/interests.bml' && $args =~ /int=(.+?)(&|$)/) {             
+     $cur = "int";
+     $val = LJ::durl($1);
+ }
+ if ($FORM{'s_loc'}) {
+     $cur = "region";
+ }
+
+ my $hval = LJ::ehtml($val);
+ $ret .= "<input id='searchlj' type='text' name='q' size='15' class='login' value='$hval'> ";
+ $ret .= '<select style="FONT-SIZE: 10px; FONT-FAMILY: verdana, arial, helvetica" name=type>';
+ foreach my $it (
+	["user", BML::ml("Username")], 
+	["email", BML::ml("Email")], 
+	["region", BML::ml("dystopia.search.region")], 
+	["int", BML::ml("dystopia.search.int")],
+	["aolim", BML::ml("dystopia.search.aolim")],
+	["icq", BML::ml("dystopia.search.icq")],
+	["yahoo", BML::ml("dystopia.search.yahoo")],
+	["msn", BML::ml("dystopia.search.msn")],
+	["jabber", BML::ml("dystopia.search.jabber")],
+	) {
+     next if ($it->[0] eq "region" && $LJ::DISABLED{'directory'});
+     my $sel = $cur eq $it->[0] ? " SELECTED" : "";
+     $ret .= "<option value=$it->[0]$sel>$it->[1]";
+ }
+ return BML::noparse($ret);
+_code?>
+			</select>
+			<img src="<?imgprefix?>/dot.gif" width="1" height="5">
+                        <input type=submit value="<?_ml btn.search _ml?>" class="login">
+			</font>
+			</td></form>
+		</tr>
+<!-- /search livejournal bar -->
+
+
+<!-- logged in bar -->
+		<tr>
+		  <td height="27" class="wtext" width="53%" colspan="2" nowrap="nowrap" valign="middle">
+<?_code
+#BML:cache
+ if (LJ::get_remote()) {
+     return BML::noparse(BML::ml("dystopia.hello_loggedin", { 'username' => LJ::get_remote()->{'user'} }));
+ } else {
+     return BML::noparse(BML::ml("dystopia.hello_anonymous"))
+ }
+_code?></td>
+		  <td height="27" width="47%" nowrap="nowrap" align="right" valign="middle">
+<a href="/"><span class="navlinks"><?_ml dystopia.nav.home _ml?></span></a> <span class="navtext">|</span>
+<a href="/site/"><span class="navlinks"><?_ml dystopia.nav.sitemap _ml?></span></a> <span class="navtext">|</span>
+<a href="/news.bml"><span class="navlinks"><?_ml dystopia.nav.news _ml?></span></a> <span class="navtext">|</span>
+<a href="/manage/siteopts.bml"><span class="navlinks"><?_ml dystopia.nav.siteopts _ml?></span></a> <span class="navtext">|</span>
+<a href="/support/"><span class="navlinks"><?_ml Help _ml?></span></a>
+<?_code
+#BML:cache
+ my $r = LJ::get_remote();
+ if ($r) {
+     return BML::noparse(' <span class="navtext">|</span> <a href="/logout.bml?user=' . "$r->{'user'}&amp;sessid=$r->{'_session'}->{'sessid'}" . '"><span class="navlinks">' . BML::ml("dystopia.nav.logout") . '</span></a>');
+ }	
+ return;
+_code?>
+<img src="<?imgprefix?>/dys/5x5.gif" width="10" height="5"></td>
+		</tr>
+<!-- /logged in bar -->
+
+	  </table>
+	</td>
+  </tr>
+<!-- /logo, search, logged in bar -->
+
+<!-- left sidebar and body -->
+
+  <tr align="left" valign="top">
+	<td bgcolor="#336699" width="<?_ml dystopia.nav.width _ml?>" height="813">
+	  <table width="<?_ml dystopia.nav.width _ml?>" border="0" cellspacing="0" cellpadding="10">
+<?_code
+#BML:cache
+ my @nav;
+ my $remote = LJ::get_remote();
+ if ($remote) {
+     push @nav, { 'name' => BML::ml('dystopia.navhead.journal'),
+		  'links' => [ { 'url' => '/update.bml',
+				 'text' => BML::ml('dystopia.nav.updatejournal'), },
+			       { 'url' => "/users/$remote->{'user'}/",
+				 'text' => BML::ml('dystopia.nav.journalrecent'), },
+			       { 'url' => "/users/$remote->{'user'}/calendar",
+				 'text' => BML::ml('dystopia.nav.journalcalendar'), },
+			       { 'url' => "/users/$remote->{'user'}/friends",
+				 'text' => BML::ml('dystopia.nav.journalfriends'),
+				 'extra' => '/friends/filter.bml', },
+			       { 'url' => "/userinfo.bml?user=$remote->{'user'}",
+				 'text' => BML::ml('dystopia.nav.journalinfo'),
+				 'extra' => "/userinfo.bml?user=$remote->{'user'}&mode=full",
+			     },
+			       { 'url' => "/tools/memories.bml?user=$remote->{'user'}",
+				 'text' => BML::ml('dystopia.nav.memories'), },
+			       { 'url' => "/editjournal.bml",
+				 'text' => BML::ml('dystopia.nav.editentries'), },
+			       ],
+	      };
+     push @nav, { 'name' => BML::ml('dystopia.navhead.settings'),
+		  'links' => [ { 'url' => '/manage/',
+                                 'text' => BML::ml('dystopia.nav.manage') },
+                               { 'url' => '/editinfo.bml',
+				 'text' => BML::ml('dystopia.nav.personalinfo') },
+			       { 'url' => "/friends/edit.bml",
+				 'text' => BML::ml('dystopia.nav.editfriends'), },
+			       { 'url' => "/editpics.bml",
+				 'text' => BML::ml('dystopia.nav.editpics'), },
+			       { 'url' => "/changepassword.bml",
+				 'text' => BML::ml('dystopia.nav.editpassword'), },
+			       { 'url' => "/modify.bml",
+				 'text' => BML::ml('dystopia.nav.modifyjournal'), },
+			       { 'url' => "/styles/edit.bml",
+				 'text' => BML::ml('dystopia.nav.editstyle'), },
+			       ],
+	      };
+ }
+ else 
+ {
+     push @nav, { 'name' => BML::ml('dystopia.navhead.welcome'),
+		  'links' => [ 
+			       { 'url' => '/login.bml',
+				 'text' => BML::ml('dystopia.nav.login'), },
+			       { 'url' => '/create.bml',
+				 'text' => BML::ml('dystopia.nav.createjournal'), },
+			       { 'url' => "/update.bml",
+				 'text' => BML::ml('dystopia.nav.updatejournal'), },
+			       ],
+	      };
+
+ }
+ 
+ push @nav, { 'name' => BML::ml('dystopia.navhead.findusers'),
+	      'links' => [ 
+			   { 'url' => '/random.bml',
+			     'text' => BML::ml('dystopia.nav.findrandom'), },
+			   $LJ::DISABLED{'directory'} ? () : 
+			   (
+			    { 'url' => '/directory.bml',
+			      'text' => BML::ml('dystopia.nav.findregion'), }
+			    ),
+			   { 'url' => '/community/',
+			     'text' => BML::ml('dystopia.nav.findcomm'), },
+			   { 'url' => '/interests.bml',
+			     'text' => BML::ml('dystopia.nav.findint'), },
+			   $LJ::DISABLED{'directory'} ? () : 
+			   (
+			    { 'url' => '/directorysearch.bml',
+			      'text' => BML::ml('dystopia.nav.finddir'), }
+			    ),
+			   ],
+	  };
+
+ push @nav, { 'name' => 'LiveJournal',
+	      'links' => [ 
+			   { 'url' => '/download/',
+			     'text' => BML::ml('dystopia.nav.download'), },
+			   { 'url' => '/paidaccounts/',
+			     'text' => BML::ml('dystopia.nav.paidaccts'), },
+			   { 'url' => '/pay/',
+			     'text' => BML::ml('dystopia.nav.paymentarea'), },
+			   ],
+	  };
+
+ push @nav, { 'name' => BML::ml('dystopia.navhead.help'),
+	      'links' => [ { 'url' => '/support/faq.bml',
+			     'text' => BML::ml('dystopia.nav.faq'), },
+			   { 'url' => '/support/',
+			     'text' => BML::ml('dystopia.nav.support'), },
+			   { 'url' => '/lostinfo.bml',
+			     'text' => BML::ml('dystopia.nav.lostinfo'), },
+			   { 'url' => '/developer/',
+			     'text' => BML::ml('dystopia.nav.developer'), },
+			   { 'url' => '/press/staff.bml',
+			     'text' => BML::ml('dystopia.nav.contact'), },
+			   ],
+	  };
+
+ push @nav, { 'name' => BML::ml('dystopia.navhead.legal'),
+	      'links' => [ { 'url' => '/tos.html',
+			     'text' => BML::ml('dystopia.nav.legaltos'), },
+			   { 'url' => '/privacy.bml',
+			     'text' => BML::ml('dystopia.nav.legalprivacy'), },
+			  # { 'url' => '/legal/dmca.bml',
+			  #   'text' => BML::ml('dystopia.nav.legaldmca'), },
+			   ],
+	  };
+
+ 
+ my $ret = $LJ::DYS_LEFT_TOP;
+ foreach my $sec (@nav) {
+     $ret .= "<tr align=left valign=top><td><p><span class=navtext>$sec->{'name'}</span><br />";
+     foreach my $l (@{$sec->{'links'}}) {
+	 $ret .= "<a href=\"$l->{'url'}\"><span class=navlinks>$l->{'text'}</span></a>";
+	 if ($l->{'extra'}) {
+	     $ret .= " <a href=\"$l->{'extra'}\"><span class=navlinks>...</span></a>";
+	 }
+	 $ret .= "<br />";
+     }
+     $ret .= "</td></tr>";
+ }
+ return BML::noparse($ret);
+
+_code?>
+		<tr align="left" valign="top">
+		  <td>&nbsp;</td>
+		</tr>
+		<tr align="left" valign="top">
+		  <td>&nbsp;</td>
+		</tr>
+		<tr align="left" valign="top">
+		  <td>&nbsp;</td>
+		</tr>
+	  </table>
+	  <p>&nbsp;</p>
+	  <p>&nbsp;</p>
+	</td>
+	<td height="813" bgcolor="#FFFFFF">
+	  <table width="100%" border="0" cellspacing="0" cellpadding="0">
+
+<!-- login bar -->
+<?_code
+#BML:cache
+#WITHPORTAL: unless ($remote || BML::get_uri() eq "/") {
+ my $remote = LJ::get_remote();
+ unless ($remote || BML::get_uri eq '/login.bml') {
+     my $button;
+     my $logincaption = BML::ml('dystopia.btn.login');
+     if ($logincaption eq 'LOGIN') {
+         if (! $LJ::IS_SSL) { 
+             $button = "<input type=image onclick='return sendForm()' src='$LJ::IMGPREFIX/dys/login_but.gif' width='48' height='15' border='0'>";
+         } else {
+             $button = "<input type=image src='$LJ::IMGPREFIX/dys/login_but.gif' width='48' height='15' border='0'>";
+         }
+     } else {
+         if (! $LJ::IS_SSL) { 
+             $button = "<input type='submit' onclick='return sendForm()' value='$ML{'dystopia.btn.login'}' style='margin-top: 0px; margin-bottom: 1px; font-weight: bold;  height: 19px; border: 1px solid #ffffff; background: #336699 none; color: #ffffff; padding-left: 0px; padding-right: 0px'></td>";
+         } else {
+             $button = "<input type='submit' value='$ML{'dystopia.btn.login'}' style='margin-top: 0px; margin-bottom: 1px; font-weight: bold;  height: 19px; border: 1px solid #ffffff; background: #336699 none; color: #ffffff; padding-left: 0px; padding-right: 0px'></td>";
+         }
+     }
+     
+     my $chal = LJ::challenge_generate(300);
+     return <<"END_LOGIN_BAR";
+     <form action="/login.bml" method="post" id='login'>
+         <input type="hidden" name="mode" value="login" />
+         <input type='hidden' name='chal' id='login_chal' value='$chal' />
+         <input type='hidden' name='response' id='login_response' value='' />
+         <tr>
+             <td align="right" valign="top" bgcolor="#FFFFFF">
+             <table border='0' cellspacing='0' cellpadding='0' width='200' align='right'>
+             <tr>
+                 <td align="left" valign="bottom" bgcolor="#660066"><img src="<?imgprefix?>/dys/lg_crnrgif.gif" width="14" height="23"></td>
+                 <td align="right" valign="middle" bgcolor="#660066" class="wtextunbld" nowrap="nowrap">&nbsp;$ML{'Username'}:&nbsp;</td>
+                 <td align="center" valign="top" bgcolor="#660066" class="wtext" nowrap="nowrap"><input type="text" name="user" size="15" maxlength="15" class="login" style="<?loginboxstyle?>"></td>
+                 <td align="right" valign="middle" bgcolor="#660066" class="wtextunbld" nowrap="nowrap">&nbsp;$ML{'Password'}:&nbsp;</td>
+                 <td align="center" valign="top" bgcolor="#660066" class="wtext" nowrap="nowrap"><input type="password" name="password" size="10" id='xc_password' class="login"></td>
+                 <td align="center" valign="middle" bgcolor="#660066" nowrap="nowrap">&nbsp;$button</tr>
+             </table>
+         </td></tr>
+         </form>
+END_LOGIN_BAR
+ }
+ return;
+
+_code?>
+<!-- /login bar -->
+
+		<tr align="left" valign="top" bgcolor="#ffffff">
+		  <td height="585" colspan="7">
+
+<!-- body area -->
+<table border="0" cellspacing="0" cellpadding="10" width="100%"><tr><td>
+
+<?breadcrumbs?>
+
+%%pretitle%%
+
+<font size="+2" face="Verdana, Arial, Helvetica" color=#000066>%%title%%</font><p>
+
+%%body%%
+
+</td></tr></table>
+<!-- /body area -->
+</td></tr></table>
+</td></tr></table>
+</body></html>
+<=PAGE
+

local/cgi-bin/bml/scheme/global.look

@@ -0,0 +1,379 @@
+_parent=>../../lj-bml-blocks.pl
+
+loginboxstyle=>{Ss}background: url(<?imgprefix?>/userinfo.gif) no-repeat; background-color: #fff; background-position: 0px 1px; padding-left: 18px; color: #00C; font-weight: bold;
+commloginboxstyle=>{Ss}background: url(<?imgprefix?>/community.gif) no-repeat; background-color: #fff; background-position: 0px 2px; padding-left: 19px; color: #00C; font-weight: bold;
+
+SECURITYPRIVATE=>{Ss}<img src="<?imgprefix?>/icon_private.gif" width=16 height=16 align=absmiddle>
+SECURITYPROTECTED=>{Ss}<img src="<?imgprefix?>/icon_protected.gif" width=14 height=15 align=absmiddle>
+LJUSER=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+LJCOMM=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/community.gif' alt='userinfo' width='16' height='16' style='vertical-align:bottom;border:0;' /></a><a href='/community/%%data%%/'><b>%%data%%</b></a></span>
+LJUSERF=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%&amp;mode=full'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+HELP=>{DR}(<a href="%%data%%"><i>help</i></a>)
+INERR=>{DR}<font color="#ff0000"><b>%%data%%</b></font>
+SOERROR=>{DR}<div><b>%%data%%</b></div>
+EMAILEX=><div style='font-family: courier; border: solid black 1px; padding: 5px;'>%%data%%</div>
+
+ENTRYFORMCSS<=
+{Ss}
+<style type="text/css">
+#EntryForm #MetaInfo {
+    width: 100%;
+}
+#EntryForm th {
+    font-size: 1em;
+}
+#EntryForm #SubmitBar {
+    background-color: #dfdfdf;
+    padding: 5px;
+    text-align: center;
+    border: 1px outset #000;
+    margin-left: auto; margin-right: auto;
+}
+#MetaInfo tr {
+    padding-bottom: 10px;
+}
+#metainfo th { 
+    text-align: left; 
+}
+#mood_preview {
+    display: none;
+}
+#datetime_box input, #datetime_box select {
+    margin-right: 2px;
+}
+#EntryForm legend {
+    font-weight: bold;
+}
+#EntryForm #Options {
+    margin-left: 0; margin-right: 0; padding: 0;
+    background-color: #dfdfdf;
+    border: 1px outset #000;
+}
+#EntryForm #Options th {
+    text-align: left;
+}
+#EntryForm #infobox {
+    text-align: center;
+}
+#EntryForm #infobox table {
+    background-color: #dfdfdf;
+    border: 2px solid <?emcolor?>;
+}
+#EntryForm textarea {
+    border: 1px inset #000;
+    padding: 2px;
+}
+#EntryForm #Security option {
+    padding-left: 18px;
+}
+#EntryForm #security_public {
+    background-image: url("<?imgprefix?>/userinfo.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_private {
+    background-image: url("<?imgprefix?>/icon_private.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_friends, #EntryForm #security_custom {
+    background-image: url("<?imgprefix?>/icon_protected.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #UserpicPreviewImage {
+    border: 1px solid #000;
+}
+#EntryForm {
+    width: 100%;
+}
+</style>
+<=ENTRYFORMCSS
+
+NEEDLOGIN<=
+<?h1 <?_ml bml.needlogin.head _ml?> h1?>
+<?p <?_ml bml.needlogin.body2 _ml?> p?>
+<=NEEDLOGIN
+
+BADINPUT<=
+<?h1 <?_ml bml.badinput.head _ml?> h1?>
+<?p <?_ml bml.badinput.body _ml?> p?>
+<=BADINPUT
+
+REQUIREPOST=><?_ml bml.requirepost _ml?>
+
+LOAD_PAGE_INFO<=
+<?_code
+#line 3
+ @sidebar = ({ 'name' => 'Home',
+	       'uri' => '/',
+	       'match' => "^/(index\\.bml)?(\\?.*)?\$",
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.create'),
+				'uri' => '/create.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.update'),
+				'uri' => '/update.bml', 
+				'children' => [
+					       { 'name' => BML::ml('ljrlook.nav.fullupdate'),
+						 'uri' => '/update.bml?mode=full', }
+					       ],
+			    },
+#			      { 'name' => 'Download',
+#				'uri' => '/download/', },
+			      ],
+	       },
+	     { 'name' => BML::ml('ljrlook.nav.site'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.news'),
+				'match' => '^/news\\.bml\$',
+				'uri' => '/community/ljr_news/', },
+			      { 'name' => BML::ml('ljrlook.nav.siteopts'),
+				'uri' => '/manage/siteopts.bml', },
+			      { 'name' => 'Sitemap',
+				'uri' => '/site/', },
+			      { 'name' => BML::ml('ljrlook.nav.paidaccounts'),
+				'uri' => '/paidaccounts/', 
+#                                'recursematch' => '^/paidaccounts/',
+#				'children' => [ 
+#						{ 'name' => 'Is this safe?',
+#						  'uri' => '/paidaccounts/whysafe.bml', },
+#						{ 'name' => 'Progress',
+#						  'uri' => '/paidaccounts/progress.bml', },
+#						],
+				},
+			      { 'name' => BML::ml('ljrlook.nav.ljfif'),
+				'uri' => '/users/ljr_fif/friends', },
+#			      { 'name' => 'To-Do list',
+#				'uri' => '/todo.bml', },
+#			      { 'name' => 'Contributors',
+#				'uri' => '/contributors.bml', },
+			      ],
+	       },
+#	     { 'name' => 'Find Users',
+#	       'children' => [
+#       			      { 'name' => 'Random!',
+#				'uri' => '/random.bml', },
+#       			      { 'name' => 'By Region',
+#				'uri' => '/directory.bml', },
+#       			      { 'name' => 'By Interest',
+#				'uri' => '/interests.bml', },
+#                              { 'name' => 'Search',	
+#				'uri' => '/directorysearch.bml', }  
+#	              ], },
+	     { 'name' => BML::ml('ljrlook.nav.edit'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.editinfo'),
+				'uri' => '/editinfo.bml', },
+#			      { 'name' => 'Settings', cont => 1,
+#				'uri' => '/editinfo.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editfriends'),
+				'uri' => '/friends/edit.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editjournal'),
+				'uri' => '/editjournal.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editpics'),
+				'uri' => '/editpics.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.changepassword'),
+				'uri' => '/changepassword.bml', },
+                              { 'name' => BML::ml('ljrlook.nav.modify'),
+				'uri' => '/modify.bml', },
+#			      { 'name' => 'Import',
+#			        'uri' => '/import.bml' },
+			      ],
+	   },
+             { 'name' => BML::ml('ljrlook.nav.communities.manage'),
+               'uri' => '/community/manage.bml'
+           },
+#	     { 'name' => 'Developer Area',
+#	       'uri' => '/developer/',
+#	       'match' => "^/developer/\$",
+#	       'recursematch' => "^/developer/",
+#	       'children' => [
+#			      { 'name' => 'Style System',
+#				'uri' => '/developer/styles.bml', 
+#				'children' => [
+#					       { 'name' => 'View Types',
+#						 'uri' => '/developer/views.bml', },
+#					       { 'name' => 'Variable List',
+#						 'uri' => '/developer/varlist.bml', },
+#					       ],
+#				},
+#			      { 'name' => 'Embedding',
+#				'uri' => '/developer/embedding.bml', },
+#			      { 'name' => 'Protocol',
+#				'uri' => '/developer/protocol.bml', 
+#				'children' => [
+#					       { 'name' => 'Mode List',
+#						 'uri' => '/developer/modelist.bml', }
+#					       ],
+#			    },
+#			      ],
+#	   },
+#	     { 'name' => BML::ml('ljrlook.nav.frills'),#Styles,customization
+#	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.customize'),
+				'uri' => '/customize/', },
+#			      { 'name' => BML::ml('ljrlook.nav.createstyle'),
+#				'uri' => '/createstyle.bml', },
+#			      { 'name' => BML::ml('ljrlook.nav.editstyle'),
+#				'uri' => '/editstyle.bml', },
+#			      ],
+#	   },
+         { 'name' => BML::ml('ljrlook.nav.needhelp'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.lostinfo'),
+				'uri' => '/lostinfo.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.support.faq'),
+				'uri' => '/support/faq.bml', },
+#			      { 'name' => 'Questions',
+#				'uri' => '/support/faq.bml', cont => 1, },
+			      { 'name' => BML::ml('ljrlook.nav.support'),
+				'uri' => '/support/', },
+			      ],
+	   },
+ );
+ 
+ my $remote = LJ::get_remote();
+ my $remuser = $remote ? $remote->{'user'} : "";
+ my $hello_name = $remote ? LJ::User::display_name($remote) : "";
+ my $uri = BML::get_uri();        
+ if ($remuser ne "" && $uri ne "/logout.bml") 
+ {
+     my $subdomain = $remuser;
+     $subdomain =~ s/_/-/g;
+     unshift @sidebar, { 'name' => BML::ml('ljrlook.nav.hello').", ".$hello_name."!",
+			 'children' => [
+					{ 'name' => BML::ml('ljrlook.nav.yourjournal'), 
+					  'children' => [
+							 { 'name' => BML::ml('ljrlook.nav.recent'),
+							   'uri' => "/users/$remuser/", },
+							 { 'name' => BML::ml('ljrlook.nav.calendar'),
+							   'uri' => "/users/$remuser/calendar", },
+							 { 'name' => BML::ml('ljrlook.nav.friends'),
+							   'uri' => "/users/$remuser/friends",
+							   'extra' => "/friendsfilter.bml",
+						       },
+							 ],
+					  },
+					{ 'name' => BML::ml('ljrlook.nav.userinfo'),
+					  'uri' => "/userinfo.bml?user=$remuser", },
+					{ 'name' => BML::ml('ljrlook.nav.memories'),
+					  'uri' => "/memories.bml?user=$remuser", },
+					{ 'name' => BML::ml('ljrlook.nav.logout'),
+					  'uri' => '/logout.bml', },
+					]
+					};
+ } elsif ($uri ne "/login.bml") {
+     unshift @sidebar, { 'name' => BML::ml('ljrlook.nav.login'),,
+			 'uri' => '/login.bml', }
+ }
+
+return "";
+_code?>
+<=LOAD_PAGE_INFO
+
+AL=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+AWAYLINK=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+
+H1=>{D}<h1>%%data%%</h1>
+H2=>{D}<h2>%%data%%</h2>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<p align='center'><font face="Arial,Helvetica" color="#CC0000" size='-1'><b>%%data%%</b></font>
+
+GRIN=>{S}&lt;grin&gt;
+HR=>{S}<hr />
+
+NEWLINE=>{S}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<P>%%data%%</P>
+
+STANDOUT<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=STANDOUT
+
+ERRORBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=ERRORBAR
+
+WARNINGBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=WARNINGBAR
+
+BADCONTENT<=
+<?h1 <?_ml Error _ml?> h1?>
+<?p <?_ml bml.badcontent.body _ml?> p?>
+<=BADCONTENT
+
+DE<=
+%%data%%
+<=DE
+
+EMCOLOR=>{S}#c0c0c0
+HOTCOLOR=>{S}#ff0000
+EMCOLORLITE=>{S}#e2e2e2
+ALTCOLOR1=>{S}#eeeeee
+ALTCOLOR2=>{S}#dddddd
+screenedbarcolor=>{S}#d0d0d0
+
+CHOICE=>{P}<dt><a href="%%data2%%"><font size="+1"><tt><b>%%data1%%</b></tt></font></a><dd><font size="2">%%data3%%</font>
+
+CHOICES<=
+{F}<table width="100%" cellpadding="2" cellspacing="5">
+<tr>
+<td valign='top' width="50%">
+<dl>
+%%items%%
+</dl>
+</td>
+<td valign='top' width="50%">
+<dl>
+%%itemsb%%
+</dl>
+</td>
+</tr>
+</table>
+<=CHOICES
+
+PAGE<=
+{Fp}<html>
+<head><title>%%title%%</title>%%head%%</head>
+<body %%bodyopts%%>
+%%body%%
+</body>
+</html>
+<=PAGE
+
+BREADCRUMBS<=
+{Fp}<?_code
+    # where are we
+    my @crumbs = LJ::get_crumb_path();
+    return unless @crumbs;
+    my @ret;
+    my $count = 0;
+    foreach my $crumb (@crumbs) {
+        # put crumbs together
+        next unless $crumb->[3]; # no blank crumbs
+        if ($crumb->[3] eq 'dynamic') {
+            # dynamic
+            unshift @ret, "<b>$crumb->[0]</b>";
+            $count++;
+        } else {
+            # non-dynamic
+            unshift @ret, $count++ == 0 ?
+                "<b>$ML{'crumb.'.$crumb->[3]}</b>" :
+                $crumb->[1] ne '' ?
+                    "<a href=\"$crumb->[1]\">$ML{'crumb.'.$crumb->[3]}</a>" :
+                    "$ML{'crumb.'.$crumb->[3]}";
+        }
+    }
+    return "<div id='ljbreadcrumbs'>" . join(" : ", @ret) . "</div>";
+_code?>
+<=BREADCRUMBS

local/cgi-bin/bml/scheme/global.look.original

@@ -0,0 +1,370 @@
+_parent=>../../lj-bml-blocks.pl
+
+loginboxstyle=>{Ss}background: url(<?imgprefix?>/userinfo.gif) no-repeat; background-color: #fff; background-position: 0px 1px; padding-left: 18px; color: #00C; font-weight: bold;
+commloginboxstyle=>{Ss}background: url(<?imgprefix?>/community.gif) no-repeat; background-color: #fff; background-position: 0px 2px; padding-left: 19px; color: #00C; font-weight: bold;
+
+SECURITYPRIVATE=>{Ss}<img src="<?imgprefix?>/icon_private.gif" width=16 height=16 align=absmiddle>
+SECURITYPROTECTED=>{Ss}<img src="<?imgprefix?>/icon_protected.gif" width=14 height=15 align=absmiddle>
+LJUSER=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+LJCOMM=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/community.gif' alt='userinfo' width='16' height='16' style='vertical-align:bottom;border:0;' /></a><a href='/community/%%data%%/'><b>%%data%%</b></a></span>
+LJUSERF=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%&amp;mode=full'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+HELP=>{DR}(<a href="%%data%%"><i>help</i></a>)
+INERR=>{DR}<font color="#ff0000"><b>%%data%%</b></font>
+SOERROR=>{DR}<div><b>%%data%%</b></div>
+EMAILEX=><div style='font-family: courier; border: solid black 1px; padding: 5px;'>%%data%%</div>
+
+ENTRYFORMCSS<=
+{Ss}
+<style type="text/css">
+#EntryForm #MetaInfo {
+    width: 100%;
+}
+#EntryForm th {
+    font-size: 1em;
+}
+#EntryForm #SubmitBar {
+    background-color: #dfdfdf;
+    padding: 5px;
+    text-align: center;
+    border: 1px outset #000;
+    margin-left: auto; margin-right: auto;
+}
+#MetaInfo tr {
+    padding-bottom: 10px;
+}
+#metainfo th { 
+    text-align: left; 
+}
+#mood_preview {
+    display: none;
+}
+#datetime_box input, #datetime_box select {
+    margin-right: 2px;
+}
+#EntryForm legend {
+    font-weight: bold;
+}
+#EntryForm #Options {
+    margin-left: 0; margin-right: 0; padding: 0;
+    background-color: #dfdfdf;
+    border: 1px outset #000;
+}
+#EntryForm #Options th {
+    text-align: left;
+}
+#EntryForm #infobox {
+    text-align: center;
+}
+#EntryForm #infobox table {
+    background-color: #dfdfdf;
+    border: 2px solid <?emcolor?>;
+}
+#EntryForm textarea {
+    border: 1px inset #000;
+    padding: 2px;
+}
+#EntryForm #Security option {
+    padding-left: 18px;
+}
+#EntryForm #security_public {
+    background-image: url("<?imgprefix?>/userinfo.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_private {
+    background-image: url("<?imgprefix?>/icon_private.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_friends, #EntryForm #security_custom {
+    background-image: url("<?imgprefix?>/icon_protected.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #UserpicPreviewImage {
+    border: 1px solid #000;
+}
+#EntryForm {
+    width: 100%;
+}
+</style>
+<=ENTRYFORMCSS
+
+NEEDLOGIN<=
+<?h1 <?_ml bml.needlogin.head _ml?> h1?>
+<?p <?_ml bml.needlogin.body2 _ml?> p?>
+<=NEEDLOGIN
+
+BADINPUT<=
+<?h1 <?_ml bml.badinput.head _ml?> h1?>
+<?p <?_ml bml.badinput.body _ml?> p?>
+<=BADINPUT
+
+REQUIREPOST=><?_ml bml.requirepost _ml?>
+
+LOAD_PAGE_INFO<=
+<?_code
+#line 3
+ @sidebar = ({ 'name' => 'Home',
+	       'uri' => '/',
+	       'match' => "^/(index\\.bml)?(\\?.*)?\$",
+	       'children' => [
+			      { 'name' => 'Create Journal',
+				'uri' => '/create.bml', },
+			      { 'name' => 'Update',
+				'uri' => '/update.bml', 
+				'children' => [
+					       { 'name' => 'Full Update',
+						 'uri' => '/update.bml?mode=full', }
+					       ],
+			    },
+#			      { 'name' => 'Download',
+#				'uri' => '/download/', },
+			      ],
+	       },
+	     { 'name' => 'LiveJournal',
+	       'children' => [
+			      { 'name' => 'News',
+				'match' => '^/news\\.bml\$',
+				'uri' => '/news.bml', },
+#			      { 'name' => 'Paid Accounts',
+#				'uri' => '/paidaccounts/', 
+#                                'recursematch' => '^/paidaccounts/',
+#				'children' => [ 
+#						{ 'name' => 'Is this safe?',
+#						  'uri' => '/paidaccounts/whysafe.bml', },
+#						{ 'name' => 'Progress',
+#						  'uri' => '/paidaccounts/progress.bml', },
+#						],
+#				},
+			      { 'name' => 'To-Do list',
+				'uri' => '/todo.bml', },
+#			      { 'name' => 'Contributors',
+#				'uri' => '/contributors.bml', },
+			      ],
+	       },
+	     { 'name' => 'Customize',
+	       'children' => [
+			      { 'name' => 'Modify Journal',
+				'uri' => '/modify.bml', 
+				'children' => [
+						{ 'name' => 'Customize S2',
+						  'uri' => '/customize/', },
+						],
+				},
+			      { 'name' => 'Create Style',
+				'uri' => '/createstyle.bml', },
+			      { 'name' => 'Edit Style',
+				'uri' => '/editstyle.bml', },
+			      ],
+	   },
+	     { 'name' => 'Find Users',
+	       'children' => [
+       			      { 'name' => 'Random!',
+				'uri' => '/random.bml', },
+       			      { 'name' => 'By Region',
+				'uri' => '/directory.bml', },
+       			      { 'name' => 'By Interest',
+				'uri' => '/interests.bml', },
+                              { 'name' => 'Search',	
+				'uri' => '/directorysearch.bml', }  
+	              ], },
+	     { 'name' => 'Edit ...',
+	       'children' => [
+			      { 'name' => 'Personal Info &',
+				'uri' => '/editinfo.bml', },
+			      { 'name' => 'Settings', cont => 1,
+				'uri' => '/editinfo.bml', },
+			      { 'name' => 'Your Friends',
+				'uri' => '/editfriends.bml', },
+			      { 'name' => 'Old Entries',
+				'uri' => '/editjournal.bml', },
+			      { 'name' => 'Your Pictures',
+				'uri' => '/editpics.bml', },
+			      { 'name' => 'Your Password',
+				'uri' => '/changepassword.bml', },
+			      ],
+	   },
+#	     { 'name' => 'Developer Area',
+#	       'uri' => '/developer/',
+#	       'match' => "^/developer/\$",
+#	       'recursematch' => "^/developer/",
+#	       'children' => [
+#			      { 'name' => 'Style System',
+#				'uri' => '/developer/styles.bml', 
+#				'children' => [
+#					       { 'name' => 'View Types',
+#						 'uri' => '/developer/views.bml', },
+#					       { 'name' => 'Variable List',
+#						 'uri' => '/developer/varlist.bml', },
+#					       ],
+#				},
+#			      { 'name' => 'Embedding',
+#				'uri' => '/developer/embedding.bml', },
+#			      { 'name' => 'Protocol',
+#				'uri' => '/developer/protocol.bml', 
+#				'children' => [
+#					       { 'name' => 'Mode List',
+#						 'uri' => '/developer/modelist.bml', }
+#					       ],
+#			    },
+#			      ],
+#	   },
+         { 'name' => 'Need Help?',
+	       'children' => [
+			      { 'name' => 'Lost Password?',
+				'uri' => '/lostinfo.bml', },
+			      { 'name' => 'Freq. Asked',
+				'uri' => '/support/faq.bml', },
+			      { 'name' => 'Questions',
+				'uri' => '/support/faq.bml', cont => 1, },
+			      { 'name' => 'Support Area',
+				'uri' => '/support/', },
+			      ],
+	   },
+ );
+ 
+ my $remote = LJ::get_remote();
+ my $remuser = $remote ? $remote->{'user'} : "";
+ my $uri = BML::get_uri();        
+ if ($remuser ne "" && $uri ne "/logout.bml") 
+ {
+     my $subdomain = $remuser;
+     $subdomain =~ s/_/-/g;
+     unshift @sidebar, { 'name' => "Hello, $remuser!",
+			 'children' => [
+					{ 'name' => 'Your Journal', 
+					  'children' => [
+							 { 'name' => 'Recent',
+							   'uri' => "/users/$remuser/", },
+							 { 'name' => 'Calendar',
+							   'uri' => "/users/$remuser/calendar", },
+							 { 'name' => 'Friends',
+							   'uri' => "/users/$remuser/friends",
+							   'extra' => "/friendsfilter.bml",
+						       },
+							 ],
+					  },
+					{ 'name' => 'User Info',
+					  'uri' => "/userinfo.bml?user=$remuser", },
+					{ 'name' => 'Memories',
+					  'uri' => "/memories.bml?user=$remuser", },
+					{ 'name' => 'Logout',
+					  'uri' => '/logout.bml', },
+					]
+					};
+ } elsif ($uri ne "/login.bml") {
+     unshift @sidebar, { 'name' => "Log In",
+			 'uri' => '/login.bml', }
+ }
+
+return "";
+_code?>
+<=LOAD_PAGE_INFO
+
+AL=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+AWAYLINK=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+
+H1=>{D}<h1>%%data%%</h1>
+H2=>{D}<h2>%%data%%</h2>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<p align='center'><font face="Arial,Helvetica" color="#CC0000" size='-1'><b>%%data%%</b></font>
+
+GRIN=>{S}&lt;grin&gt;
+HR=>{S}<hr />
+
+NEWLINE=>{S}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<P>%%data%%</P>
+
+STANDOUT<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=STANDOUT
+
+ERRORBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=ERRORBAR
+
+WARNINGBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=WARNINGBAR
+
+BADCONTENT<=
+<?h1 <?_ml Error _ml?> h1?>
+<?p <?_ml bml.badcontent.body _ml?> p?>
+<=BADCONTENT
+
+DE<=
+%%data%%
+<=DE
+
+EMCOLOR=>{S}#c0c0c0
+HOTCOLOR=>{S}#ff0000
+EMCOLORLITE=>{S}#e2e2e2
+ALTCOLOR1=>{S}#eeeeee
+ALTCOLOR2=>{S}#dddddd
+screenedbarcolor=>{S}#d0d0d0
+
+CHOICE=>{P}<dt><a href="%%data2%%"><font size="+1"><tt><b>%%data1%%</b></tt></font></a><dd><font size="2">%%data3%%</font>
+
+CHOICES<=
+{F}<table width="100%" cellpadding="2" cellspacing="5">
+<tr>
+<td valign='top' width="50%">
+<dl>
+%%items%%
+</dl>
+</td>
+<td valign='top' width="50%">
+<dl>
+%%itemsb%%
+</dl>
+</td>
+</tr>
+</table>
+<=CHOICES
+
+PAGE<=
+{Fp}<html>
+<head><title>%%title%%</title>%%head%%</head>
+<body %%bodyopts%%>
+%%body%%
+</body>
+</html>
+<=PAGE
+
+BREADCRUMBS<=
+{Fp}<?_code
+    # where are we
+    my @crumbs = LJ::get_crumb_path();
+    return unless @crumbs;
+    my @ret;
+    my $count = 0;
+    foreach my $crumb (@crumbs) {
+        # put crumbs together
+        next unless $crumb->[3]; # no blank crumbs
+        if ($crumb->[3] eq 'dynamic') {
+            # dynamic
+            unshift @ret, "<b>$crumb->[0]</b>";
+            $count++;
+        } else {
+            # non-dynamic
+            unshift @ret, $count++ == 0 ?
+                "<b>$ML{'crumb.'.$crumb->[3]}</b>" :
+                $crumb->[1] ne '' ?
+                    "<a href=\"$crumb->[1]\">$ML{'crumb.'.$crumb->[3]}</a>" :
+                    "$ML{'crumb.'.$crumb->[3]}";
+        }
+    }
+    return "<div id='ljbreadcrumbs'>" . join(" : ", @ret) . "</div>";
+_code?>
+<=BREADCRUMBS

local/cgi-bin/bml/scheme/ljr.look

@@ -0,0 +1,374 @@
+_parent=>../../lj-bml-blocks.pl
+
+loginboxstyle=>{Ss}background: url(<?imgprefix?>/userinfo.gif) no-repeat; background-color: #fff; background-position: 0px 1px; padding-left: 18px; color: #00C; font-weight: bold;
+commloginboxstyle=>{Ss}background: url(<?imgprefix?>/community.gif) no-repeat; background-color: #fff; background-position: 0px 2px; padding-left: 19px; color: #00C; font-weight: bold;
+
+SECURITYPRIVATE=>{Ss}<img src="<?imgprefix?>/icon_private.gif" width=16 height=16 align=absmiddle>
+SECURITYPROTECTED=>{Ss}<img src="<?imgprefix?>/icon_protected.gif" width=14 height=15 align=absmiddle>
+LJUSER=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+LJCOMM=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/community.gif' alt='userinfo' width='16' height='16' style='vertical-align:bottom;border:0;' /></a><a href='/community/%%data%%/'><b>%%data%%</b></a></span>
+LJUSERF=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%&amp;mode=full'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
+HELP=>{DR}(<a href="%%data%%"><i>help</i></a>)
+INERR=>{DR}<font color="#ff0000"><b>%%data%%</b></font>
+SOERROR=>{DR}<div><b>%%data%%</b></div>
+EMAILEX=><div style='font-family: courier; border: solid black 1px; padding: 5px;'>%%data%%</div>
+
+ENTRYFORMCSS<=
+{Ss}
+<style type="text/css">
+#EntryForm #MetaInfo {
+    width: 100%;
+}
+#EntryForm th {
+    font-size: 1em;
+}
+#EntryForm #SubmitBar {
+    background-color: #dfdfdf;
+    padding: 5px;
+    text-align: center;
+    border: 1px outset #000;
+    margin-left: auto; margin-right: auto;
+}
+#MetaInfo tr {
+    padding-bottom: 10px;
+}
+#metainfo th { 
+    text-align: left; 
+}
+#mood_preview {
+    display: none;
+}
+#datetime_box input, #datetime_box select {
+    margin-right: 2px;
+}
+#EntryForm legend {
+    font-weight: bold;
+}
+#EntryForm #Options {
+    margin-left: 0; margin-right: 0; padding: 0;
+    background-color: #dfdfdf;
+    border: 1px outset #000;
+}
+#EntryForm #Options th {
+    text-align: left;
+}
+#EntryForm #infobox {
+    text-align: center;
+}
+#EntryForm #infobox table {
+    background-color: #dfdfdf;
+    border: 2px solid <?emcolor?>;
+}
+#EntryForm textarea {
+    border: 1px inset #000;
+    padding: 2px;
+}
+#EntryForm #Security option {
+    padding-left: 18px;
+}
+#EntryForm #security_public {
+    background-image: url("<?imgprefix?>/userinfo.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_private {
+    background-image: url("<?imgprefix?>/icon_private.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #security_friends, #EntryForm #security_custom {
+    background-image: url("<?imgprefix?>/icon_protected.gif");
+    background-repeat: no-repeat;
+}
+#EntryForm #UserpicPreviewImage {
+    border: 1px solid #000;
+}
+#EntryForm {
+    width: 100%;
+}
+</style>
+<=ENTRYFORMCSS
+
+NEEDLOGIN<=
+<?h1 <?_ml bml.needlogin.head _ml?> h1?>
+<?p <?_ml bml.needlogin.body2 _ml?> p?>
+<=NEEDLOGIN
+
+BADINPUT<=
+<?h1 <?_ml bml.badinput.head _ml?> h1?>
+<?p <?_ml bml.badinput.body _ml?> p?>
+<=BADINPUT
+
+REQUIREPOST=><?_ml bml.requirepost _ml?>
+
+LOAD_PAGE_INFO<=
+<?_code
+#line 3
+ @sidebar = ({ 'name' => 'Home',
+	       'uri' => '/',
+	       'match' => "^/(index\\.bml)?(\\?.*)?\$",
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.create'),
+				'uri' => '/create.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.update'),
+				'uri' => '/update.bml', 
+				'children' => [
+					       { 'name' => BML::ml('ljrlook.nav.fullupdate'),
+						 'uri' => '/update.bml?mode=full', }
+					       ],
+			    },
+#			      { 'name' => 'Download',
+#				'uri' => '/download/', },
+			      ],
+	       },
+	     { 'name' => BML::ml('ljrlook.nav.site'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.news'),
+				'match' => '^/news\\.bml\$',
+				'uri' => '/community/ljr_news/', },
+			      { 'name' => BML::ml('ljrlook.nav.siteopts'),
+				'uri' => '/manage/siteopts.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.paidaccounts'),
+				'uri' => '/paidaccounts/', 
+#                                'recursematch' => '^/paidaccounts/',
+#				'children' => [ 
+#						{ 'name' => 'Is this safe?',
+#						  'uri' => '/paidaccounts/whysafe.bml', },
+#						{ 'name' => 'Progress',
+#						  'uri' => '/paidaccounts/progress.bml', },
+#						],
+				},
+			      { 'name' => BML::ml('ljrlook.nav.ljfif'),
+				'uri' => '/users/ljr_fif/friends', },
+#			      { 'name' => 'To-Do list',
+#				'uri' => '/todo.bml', },
+#			      { 'name' => 'Contributors',
+#				'uri' => '/contributors.bml', },
+			      ],
+	       },
+#	     { 'name' => 'Find Users',
+#	       'children' => [
+#       			      { 'name' => 'Random!',
+#				'uri' => '/random.bml', },
+#       			      { 'name' => 'By Region',
+#				'uri' => '/directory.bml', },
+#       			      { 'name' => 'By Interest',
+#				'uri' => '/interests.bml', },
+#                              { 'name' => 'Search',	
+#				'uri' => '/directorysearch.bml', }  
+#	              ], },
+	     { 'name' => BML::ml('ljrlook.nav.edit'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.editinfo'),
+				'uri' => '/editinfo.bml', },
+#			      { 'name' => 'Settings', cont => 1,
+#				'uri' => '/editinfo.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editfriends'),
+				'uri' => '/editfriends.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editjournal'),
+				'uri' => '/editjournal.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editpics'),
+				'uri' => '/editpics.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.changepassword'),
+				'uri' => '/changepassword.bml', },
+                              { 'name' => BML::ml('ljrlook.nav.modify'),
+				'uri' => '/modify.bml', },
+			      ],
+	   },
+             { 'name' => BML::ml('ljrlook.nav.communities.manage'),
+               'uri' => '/community/manage.bml'
+           },
+#	     { 'name' => 'Developer Area',
+#	       'uri' => '/developer/',
+#	       'match' => "^/developer/\$",
+#	       'recursematch' => "^/developer/",
+#	       'children' => [
+#			      { 'name' => 'Style System',
+#				'uri' => '/developer/styles.bml', 
+#				'children' => [
+#					       { 'name' => 'View Types',
+#						 'uri' => '/developer/views.bml', },
+#					       { 'name' => 'Variable List',
+#						 'uri' => '/developer/varlist.bml', },
+#					       ],
+#				},
+#			      { 'name' => 'Embedding',
+#				'uri' => '/developer/embedding.bml', },
+#			      { 'name' => 'Protocol',
+#				'uri' => '/developer/protocol.bml', 
+#				'children' => [
+#					       { 'name' => 'Mode List',
+#						 'uri' => '/developer/modelist.bml', }
+#					       ],
+#			    },
+#			      ],
+#	   },
+	     { 'name' => BML::ml('ljrlook.nav.frills'),#Styles,customization
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.customize'),
+				'uri' => '/customize/', },
+			      { 'name' => BML::ml('ljrlook.nav.createstyle'),
+				'uri' => '/createstyle.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.editstyle'),
+				'uri' => '/editstyle.bml', },
+			      ],
+	   },
+         { 'name' => BML::ml('ljrlook.nav.needhelp'),
+	       'children' => [
+			      { 'name' => BML::ml('ljrlook.nav.lostinfo'),
+				'uri' => '/lostinfo.bml', },
+			      { 'name' => BML::ml('ljrlook.nav.support.faq'),
+				'uri' => '/support/faq.bml', },
+#			      { 'name' => 'Questions',
+#				'uri' => '/support/faq.bml', cont => 1, },
+			      { 'name' => BML::ml('ljrlook.nav.support'),
+				'uri' => '/support/', },
+			      ],
+	   },
+ );
+ 
+ my $remote = LJ::get_remote();
+ my $remuser = $remote ? $remote->{'user'} : "";
+ my $uri = BML::get_uri();        
+ if ($remuser ne "" && $uri ne "/logout.bml") 
+ {
+     my $subdomain = $remuser;
+     $subdomain =~ s/_/-/g;
+     unshift @sidebar, { 'name' => BML::ml('ljrlook.nav.hello').", ".$remuser."!",
+			 'children' => [
+					{ 'name' => BML::ml('ljrlook.nav.yourjournal'), 
+					  'children' => [
+							 { 'name' => BML::ml('ljrlook.nav.recent'),
+							   'uri' => "/users/$remuser/", },
+							 { 'name' => BML::ml('ljrlook.nav.calendar'),
+							   'uri' => "/users/$remuser/calendar", },
+							 { 'name' => BML::ml('ljrlook.nav.friends'),
+							   'uri' => "/users/$remuser/friends",
+							   'extra' => "/friendsfilter.bml",
+						       },
+							 ],
+					  },
+					{ 'name' => BML::ml('ljrlook.nav.userinfo'),
+					  'uri' => "/userinfo.bml?user=$remuser", },
+					{ 'name' => BML::ml('ljrlook.nav.memories'),
+					  'uri' => "/memories.bml?user=$remuser", },
+					{ 'name' => BML::ml('ljrlook.nav.logout'),
+					  'uri' => '/logout.bml', },
+					]
+					};
+ } elsif ($uri ne "/login.bml") {
+     unshift @sidebar, { 'name' => BML::ml('ljrlook.nav.login'),,
+			 'uri' => '/login.bml', }
+ }
+
+return "";
+_code?>
+<=LOAD_PAGE_INFO
+
+AL=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+AWAYLINK=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
+
+H1=>{D}<h1>%%data%%</h1>
+H2=>{D}<h2>%%data%%</h2>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<p align='center'><font face="Arial,Helvetica" color="#CC0000" size='-1'><b>%%data%%</b></font>
+
+GRIN=>{S}&lt;grin&gt;
+HR=>{S}<hr />
+
+NEWLINE=>{S}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<P>%%data%%</P>
+
+STANDOUT<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=STANDOUT
+
+ERRORBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=ERRORBAR
+
+WARNINGBAR<=
+{D}<blockquote>
+<hr />
+%%data%%
+<hr />
+</blockquote>
+<=WARNINGBAR
+
+BADCONTENT<=
+<?h1 <?_ml Error _ml?> h1?>
+<?p <?_ml bml.badcontent.body _ml?> p?>
+<=BADCONTENT
+
+DE<=
+%%data%%
+<=DE
+
+EMCOLOR=>{S}#c0c0c0
+HOTCOLOR=>{S}#ff0000
+EMCOLORLITE=>{S}#e2e2e2
+ALTCOLOR1=>{S}#eeeeee
+ALTCOLOR2=>{S}#dddddd
+screenedbarcolor=>{S}#d0d0d0
+
+CHOICE=>{P}<dt><a href="%%data2%%"><font size="+1"><tt><b>%%data1%%</b></tt></font></a><dd><font size="2">%%data3%%</font>
+
+CHOICES<=
+{F}<table width="100%" cellpadding="2" cellspacing="5">
+<tr>
+<td valign='top' width="50%">
+<dl>
+%%items%%
+</dl>
+</td>
+<td valign='top' width="50%">
+<dl>
+%%itemsb%%
+</dl>
+</td>
+</tr>
+</table>
+<=CHOICES
+
+PAGE<=
+{Fp}<html>
+<head><title>%%title%%</title>%%head%%</head>
+<body %%bodyopts%%>
+%%body%%
+</body>
+</html>
+<=PAGE
+
+BREADCRUMBS<=
+{Fp}<?_code
+    # where are we
+    my @crumbs = LJ::get_crumb_path();
+    return unless @crumbs;
+    my @ret;
+    my $count = 0;
+    foreach my $crumb (@crumbs) {
+        # put crumbs together
+        next unless $crumb->[3]; # no blank crumbs
+        if ($crumb->[3] eq 'dynamic') {
+            # dynamic
+            unshift @ret, "<b>$crumb->[0]</b>";
+            $count++;
+        } else {
+            # non-dynamic
+            unshift @ret, $count++ == 0 ?
+                "<b>$ML{'crumb.'.$crumb->[3]}</b>" :
+                $crumb->[1] ne '' ?
+                    "<a href=\"$crumb->[1]\">$ML{'crumb.'.$crumb->[3]}</a>" :
+                    "$ML{'crumb.'.$crumb->[3]}";
+        }
+    }
+    return "<div id='ljbreadcrumbs'>" . join(" : ", @ret) . "</div>";
+_code?>
+<=BREADCRUMBS

local/cgi-bin/bml/scheme/opalcat.look

@@ -0,0 +1,225 @@
+_parent=>global.look
+
+AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="<?imgprefix?>/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="<?imgprefix?>/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+
+H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+
+H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+GRIN=>&lt;grin&gt;
+HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
+
+DE<=
+<font size=-1>%%DATA%%</font>
+<=DE
+
+NEWLINE=>{D}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<BR>%%DATA%%
+P/FOLLOW_P=>{D}<BR><IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
+
+STANDOUTO<=
+{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
+BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
+%%DATA%%
+
+</TD></TR></TABLE></CENTER>
+<=STANDOUTO
+
+STANDOUT<=
+{D}<CENTER><FONT SIZE=1><BR></FONT>
+<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
+ <tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="<?imgprefix?>/corn_nw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="<?imgprefix?>/corn_ne.gif" alt=""></td>
+ </tr><tr>
+  <td width=7>
+   <img width=7 height=1 src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td valign=top>
+%%DATA%%
+
+  </td>
+  <td width=7>
+   <img width=7 height=1 src="<?imgprefix?>/dot.gif" alt=""></td>
+ </tr><tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="<?imgprefix?>/corn_sw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="<?imgprefix?>/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="<?imgprefix?>/corn_se.gif" alt=""></td>
+ </tr>
+</table>
+
+</CENTER>
+<=STANDOUT
+
+######################### choices stuff
+
+CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
+
+CHOICES<=
+{F}<P><DIV CLASS="choice"><TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
+<TR>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMS%%
+</DL>
+</TD>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMSB%%
+</DL>
+</TD>
+</TR>
+</TABLE></DIV>
+<=CHOICES
+
+##################################################################################
+################################### MAIN PAGE ####################################
+##################################################################################
+
+PAGE<=
+{F}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<HTML><?load_page_info?>
+<HEAD>
+<LINK REL="SHORTCUT ICON" HREF="http://www.livejournal.com/favicon.ico">
+<TITLE>%%TITLE%%</TITLE>
+%%HEAD%%
+<SCRIPT LANGUAGE="JavaScript">
+  window.onerror = null;  // damn javascript.
+</SCRIPT>
+</HEAD>
+<BODY BGCOLOR=#FFFFFF TOPMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" BOTTOMMARGIN="0"
+      MARGINHEIGHT="0" MARGINWIDTH="0" LINK=#0000C0 VLINK=#600060
+      BACKGROUND="<?imgprefix?>/opal/spiral2.jpg" %%bodyopts%%>
+
+<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=100% HEIGHT=100%>
+<TR VALIGN=TOP>
+<TD WIDTH=128 NOWRAP>
+
+<IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 HEIGHT=15><BR>
+
+<FONT FACE="Arial,Helvetica" SIZE=-1>
+<?_code
+
+ $ret = "";
+
+ sub dump_entry 
+ {
+     my ($ret, $listref, $depth) = @_;
+
+     foreach my $mi (@$listref) 
+     {
+	 if ($depth==0) { 
+	     $$ret .= "<P><IMG SRC=\"<?imgprefix?>/opal/bullet.gif\" WIDTH=10 HEIGHT=10 HSPACE=2 ALIGN=ABSMIDDLE>";
+	 } else {
+	     $$ret .= "&nbsp;" x ($depth*3+1);
+	     $$ret .= $mi->{'cont'} ? "&nbsp;&nbsp;" : "- ";
+	 }
+
+	 my $extra = "";
+	 if ($mi->{'extra'}) {
+	     $extra = " <A HREF=\"$mi->{'extra'}\">...</A>";
+	 }
+
+	 my $name = $mi->{'name'};
+	 $name =~ s/ /&nbsp;/g;
+	 if (! defined $mi->{'uri'}) {
+	     if ($depth == 0) {
+		 $$ret .= "<B>$name</B>$extra<BR>";
+	     } else {
+		 $$ret .= "$name$extra<BR>";
+	     }
+	 } elsif ($mi->{'match'} ? 
+		  (BML::get_uri() =~ /$mi->{'match'}/) :
+		  (BML::get_uri() eq $mi->{'uri'})
+		  ){
+	     $$ret .= "<B><SPAN style=\"background-color: #D0D0FF\"><FONT COLOR=#0000D0>$name</FONT></SPAN></B>$extra<BR>";
+	 } else {
+	     $$ret .= "<A HREF=\"$mi->{'uri'}\">$name</A>$extra<BR>";
+	 }
+
+	 if ($mi->{'children'} && 
+	     ($mi->{'recursematch'} ? BML::get_uri() =~ /$mi->{'recursematch'}/ : 1)) {
+	     &dump_entry($ret, $mi->{'children'}, $depth+1);
+	 }
+     }
+     
+ }
+
+&dump_entry(\$ret, \@sidebar, 0);
+
+ return $ret;
+
+_code?>
+</FONT>
+
+</TD>
+<TD ALIGN=LEFT WIDTH=39 NOWRAP><BR></TD>
+
+</TD>
+<TD WIDTH=100%>
+
+   <TABLE HEIGHT=95 WIDTH=100% BORDER=0 cellpadding=0 cellspacing=0>
+      <TR>
+        <TD VALIGN=TOP ALIGN=RIGHT>
+<?_code
+$is_home = (BML::get_uri() =~ m!^/(index\.bml)?!);
+if (! $is_home)
+{
+	return '<P><A HREF="/"><IMG SRC="<?imgprefix?>/opal/home.gif" WIDTH=87 HEIGHT=51 BORDER=0 HSPACE=0></A></P>';
+} else {
+	return "<P>&nbsp;</P>";
+}
+return "";
+_code?>
+
+<P align=left><FONT SIZE=6 COLOR="#000a3f" FACE="Arial, Helvetica"><B>%%TITLE%%</B></FONT>
+<BR><IMG SRC="<?imgprefix?>/opal/pencil-line.gif" WIDTH=345 HEIGHT=23></P>
+
+      </TD>
+    </TR>
+    </TABLE>
+
+
+<IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 HEIGHT=5><BR>
+
+<TABLE WIDTH=100%>
+<TR><TD ALIGN=LEFT>
+%%BODY%%
+</TD>
+<TD WIDTH=20>&nbsp;</TD>
+</TR>
+</TABLE>
+
+</TD>
+</TR>
+
+<TR ALIGN=RIGHT>
+<TD>&nbsp;</TD><TD>&nbsp;</TD>
+<TD>
+<P>&nbsp;<P>
+	<FONT FACE="Arial, Helvetica" SIZE="-2">
+		<A HREF="/tos.html">Terms of Service</A><BR>
+		<A HREF="/privacy.bml">Privacy Policy</A> -
+		<A HREF="/legal/coppa.bml">COPPA</A>
+	</FONT>
+</TD>
+</TR>
+</TABLE>
+
+</BODY>
+</HTML>
+<=PAGE
+

local/cgi-bin/bml/scheme/redwhite.look

@@ -0,0 +1,267 @@
+#
+# Welcome to GENERIC.LOOK for the WhiteBlue scheme
+#
+# by....
+# 	Brad Fitzpatrick
+# 	brad@danga.com
+#
+
+######################### little stuff
+
+_parent=>global.look
+
+AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
+
+H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
+
+H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+# Banner Header: search results banner, content desriptor, etc...
+BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
+
+GRIN=>&lt;grin&gt;
+HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
+
+NEWLINE=>{D}<BR>&nbsp;&nbsp;&nbsp;&nbsp;
+P=>{D}<BR>%%DATA%%
+P/FOLLOW_P=>{D}<BR><IMG SRC="/img/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
+
+STANDOUTO<=
+{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
+BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
+%%DATA%%
+
+</TD></TR></TABLE></CENTER>
+<=STANDOUTO
+
+STANDOUT<=
+{D}<CENTER><FONT SIZE=1><BR></FONT>
+<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
+ <tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="/img/corn_nw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="/img/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="/img/corn_ne.gif" alt=""></td>
+ </tr><tr>
+  <td width=7>
+   <img width=7 height=1 src="/img/dot.gif" alt=""></td>
+  <td valign=top>
+%%DATA%%
+
+  </td>
+  <td width=7>
+   <img width=7 height=1 src="/img/dot.gif" alt=""></td>
+ </tr><tr>
+  <td width=7 align=left valign=top>
+   <img width=7 height=7 src="/img/corn_sw.gif" alt=""></td>
+  <td height=7>
+   <img height=7 src="/img/dot.gif" alt=""></td>
+  <td width=7 valign=top align=right>
+   <img height=7 src="/img/corn_se.gif" alt=""></td>
+ </tr>
+</table>
+
+</CENTER>
+<=STANDOUT
+SOERROR=><div style='background-color:#f3f4fe; color:red; font-weight:bold; text-align:center'>%%data%%</div>
+EMAILEX=><div style='width: 50%; font-family: courier; background-color: #efefef; border: dotted #cdcdcd 2px; padding: 5px;'>%%data%%</div>
+
+######################### choices stuff
+
+CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
+
+CHOICES<=
+{F}<P><DIV CLASS="choice"><TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
+<TR>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMS%%
+</DL>
+</TD>
+<TD VALIGN=TOP WIDTH="50%">
+<DL>
+%%ITEMSB%%
+</DL>
+</TD>
+</TR>
+</TABLE></DIV>
+<=CHOICES
+
+##################################################################################
+################################### MAIN PAGE ####################################
+##################################################################################
+
+PAGE<=
+{Fps}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<HTML><?load_page_info?>
+<HEAD>
+<title><?_code {
+    my $elhash = $_[2];
+    return $elhash->{'WINDOWTITLE'} || $elhash->{'TITLE'};
+} _code?></title>
+%%head%%
+<?_code
+    use strict;
+    my $crumb_up;
+    if(LJ::get_active_crumb() ne '')
+    {
+        my $parentcrumb = LJ::get_parent_crumb();
+        $crumb_up = "<link rel='up' title='$parentcrumb->[0]' href='$parentcrumb->[1]' />";
+    }
+    return $crumb_up;
+_code?>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF TOPMARGIN="0" LEFTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0" LINK=#0000C0 VLINK=#600060 %%bodyopts%%>
+
+<TABLE WIDTH=100% BORDER=0 CELLPADDING=0 CELLSPACING=0 BACKGROUND="/img/bluewhite/bluefade.jpg">
+<TR WIDTH=100%>
+<TD VALIGN=BOTTOM ALIGN=LEFT HEIGHT=100>
+
+   <TABLE BACKGROUND="" HEIGHT=95 WIDTH=100% BORDER=0>
+      <TR>
+        <TD WIDTH=3>&nbsp;</TD>
+        <TD HEIGHT=53 WIDTH=406 VALIGN=BOTTOM>
+<?_code
+$is_home = (BML::get_uri() =~ m!^/(index\.bml)?!);
+if (0 && $is_home)
+{
+	return '<IMG SRC="/img/bluewhite/title.gif" WIDTH=600 HEIGHT=53><!-- ';
+}
+return "";
+_code?>
+
+<FONT SIZE=6 COLOR="#000a3f" FACE="Arial, Helvetica"><B>%%TITLE%%</B></FONT>
+
+<?_code
+if (0 && $is_home)
+{
+	return ' -->';
+}
+return "";
+_code?>
+
+      </TD>
+      <TD VALIGN=TOP ALIGN=RIGHT>
+<?_code
+ unless ($is_home) {
+     return "<A HREF=\"/\"><IMG SRC=\"/img/bluewhite/home.gif\" WIDTH=35 HEIGHT=36 BORDER=0></A>&nbsp;";
+ }
+ return "";
+_code?>
+      </TD>
+    </TR>
+    </TABLE>
+
+</TD></TR>
+<TR><TD bgcolor="#FFFFFF"><?breadcrumbs?></TD></TR>
+</TABLE>
+
+<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>
+<TR VALIGN=TOP>
+<TD WIDTH=155 BGCOLOR=#d7d9e8 NOWRAP><IMG SRC="/img/bluewhite/hline.gif" WIDTH=155 HEIGHT=25 ALT="">
+
+<TABLE WIDTH=153 BORDER=0 CELLSPACING=0 CELLPADDING=0>
+<TR><TD>
+
+<FONT FACE="Arial,Helvetica" SIZE=-1>
+<?_code
+
+ $ret = "";
+
+ sub dump_entry 
+ {
+     my ($ret, $listref, $depth) = @_;
+
+     foreach my $mi (@$listref) 
+     {
+	 if ($depth==0) { 
+	     $$ret .= "<P><IMG SRC=\"/img/bluewhite/bullet.gif\" WIDTH=10 HEIGHT=10 HSPACE=2 ALIGN=ABSMIDDLE>";
+	 } else {
+	     $$ret .= "&nbsp;" x ($depth*3+1);
+	     $$ret .= $mi->{'cont'} ? "&nbsp;&nbsp;" : "- ";
+	 }
+
+	 my $name = $mi->{'name'};
+	 $name =~ s/ /&nbsp;/g;
+	 if (! defined $mi->{'uri'}) {
+	     if ($depth == 0) {
+		 $$ret .= "<B>$name</B><BR>";
+	     } else {
+		 $$ret .= "$name<BR>";
+	     }
+	 } elsif ($mi->{'match'} ? 
+		  (BML::get_uri() =~ /$mi->{'match'}/) :
+		  (BML::get_uri() eq $mi->{'uri'})
+		  ){
+	     $$ret .= "<B><SPAN style=\"background-color: #FFFFFF\"><FONT COLOR=#0000D0>$name</FONT></SPAN></B><BR>";
+	 } else {
+	     $$ret .= "<A HREF=\"$mi->{'uri'}\">$name</A><BR>";
+	 }
+
+	 if ($mi->{'children'} && 
+	     ($mi->{'recursematch'} ? BML::get_uri() =~ /$mi->{'recursematch'}/ : 1)) {
+	     &dump_entry($ret, $mi->{'children'}, $depth+1);
+	 }
+     }
+     
+ }
+
+&dump_entry(\$ret, \@sidebar, 0);
+
+ return $ret;
+
+_code?>
+</FONT>
+
+</TD></TR></TABLE>
+</TD>
+<TD ALIGN=LEFT BACKGROUND="/img/bluewhite/vline.gif" WIDTH=25 NOWRAP>
+   <IMG SRC="/img/bluewhite/linetop.gif" WIDTH=25 HEIGHT=25 ALT=""><BR>
+   <IMG SRC="/img/bluewhite/vline.gif" WIDTH=25 HEIGHT=800 ALT="">
+</TD>
+<TD>
+
+<IMG SRC="/img/dot.gif" WIDTH=1 HEIGHT=3><BR>
+%%BODY%%
+
+</TD>
+<TD WIDTH=20>&nbsp;</TD>
+</TR>
+
+<!-- table closure row -->
+<TR>
+<TD WIDTH=155 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade.gif" WIDTH=155 HEIGHT=25 ALT=""></TD>
+<TD WIDTH=25 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade_line.gif" WIDTH=25 HEIGHT=25 ALT=""></TD></TD>
+<TD>
+&nbsp;
+</TD>
+<TD WIDTH=20>&nbsp;</TD>
+</TR>
+</TABLE>
+<!-- /table closure row -->
+
+<!--<TABLE WIDTH=100%>
+<TR>
+<TD ALIGN=RIGHT>
+	<FONT FACE="Arial, Helvetica" SIZE="-2">
+		<A HREF="/privacy.bml">Privacy Policy</A> - 
+		<A HREF="/coppa.bml">COPPA</A><BR>
+		<A HREF="/disclaimer.bml">Legal Disclaimer</A> - 
+		<A HREF="/sitemap.bml">Site Map</A><BR>
+	</FONT>
+</TD>
+</TR>
+</TABLE>
+-->
+
+</BODY>
+</HTML>
+<=PAGE
+

local/cgi-bin/bml/scheme/vari

@@ -0,0 +1,32 @@
+ljrlook.nav.create
+ljrlook.nav.update
+ljrlook.nav.fullupdate
+ljrlook.nav.site
+ljrlook.nav.news
+ljrlook.nav.paidaccounts
+ljrlook.nav.edit
+ljrlook.nav.modify
+ljrlook.nav.editinfo
+ljrlook.nav.editfriends
+ljrlook.nav.editjournal
+ljrlook.nav.editpics
+ljrlook.nav.changepassword
+ljrlook.nav.communities.manage
+ljrlook.nav.frills
+ljrlook.nav.customize
+ljrlook.nav.createstyle
+ljrlook.nav.editstyle
+ljrlook.nav.needhelp
+ljrlook.nav.lostinfo
+ljrlook.nav.support.faq
+ljrlook.nav.support
+
+ljrlook.nav.hello
+ljrlook.nav.yourjournal
+ljrlook.nav.recent
+ljrlook.nav.calendar
+ljrlook.nav.friends
+ljrlook.nav.userinfo
+ljrlook.nav.memories
+ljrlook.nav.logout
+ljrlook.nav.login

local/cgi-bin/communitylib-local.pl

@@ -0,0 +1,75 @@
+# <LJFUNC>
+# name: LJ::comm_member_request
+# des: Registers an authaction to add a user to a
+#      community and sends an approval email
+#
+#   taken from lilib.pl, version 1.681:
+#     http://cvs.livejournal.org/browse.cgi/livejournal/cgi-bin/ljlib.pl?rev=1.681&content-type=text/x-cvsweb-markup
+#
+# returns: Hashref; output of LJ::register_authaction()
+#          includes datecreate of old row if no new row was created
+# args: comm, u, attr?
+# des-comm: Community user object
+# des-u: User object to add to community
+# des-attr: array of attributes new user will have
+# </LJFUNC>
+sub comm_member_request {
+    my ($comm, $u, $attr) = @_;
+    return undef unless ref $comm && ref $u;
+
+    my $arg = join("&", "targetid=$u->{'userid'}", map { "$_=1" } sort @$attr);
+
+    my $dbh = LJ::get_db_writer();
+
+    # check for duplicates within the same hour (to prevent spamming)
+    my $oldaa = $dbh->selectrow_hashref("SELECT aaid, authcode, datecreate FROM authactions " .
+                                        "WHERE userid=? AND arg1=? " .
+                                        "AND action='comm_invite' AND used='N' " .
+                                        "AND NOW() < datecreate + INTERVAL 1 HOUR " .
+                                        "ORDER BY 1 DESC LIMIT 1",
+                                        undef, $comm->{'userid'}, $arg);
+    return $oldaa if $oldaa;
+
+    # insert authactions row
+    my $aa = LJ::register_authaction($comm->{'userid'}, 'comm_invite', $arg);
+    return undef unless $aa;
+
+    # if there are older duplicates, invalidate any existing unused authactions of this type
+    $dbh->do("UPDATE authactions SET used='Y' WHERE userid=? AND aaid<>? AND arg1=? " .
+             "AND action='comm_invite' AND used='N'",
+             undef, $comm->{'userid'}, $aa->{'aaid'}, $arg);
+
+    # email recipient user for confirmation
+    $attr ||= [];
+    my %attr_map = ('member'     => "ÕÞÁÓÔÎÉË",
+                    'admin'      => "ÓÍÏÔÒÉÔÅÌØ",
+                    'post'       => "ÍÏÖÅÔ ÐÉÓÁÔØ",
+                    'moderate'   => "ÍÏÄÅÒÁÔÏÒ",
+                    'preapprove' => "ÎÅÍÏÄÅÒÉÒÕÅÍÏÅ",
+                    );
+
+    my $cuser = $comm->{'user'};
+    my $body = "õ×ÁÖÁÅÍÙÊ $u->{'user'},\n\n";
+    $body .= "ÓÍÏÔÒÉÔÅÌØ ÓÏÏÂÝÅÓÔ×Á $cuser ($LJ::SITEROOT/community/$cuser/)\n" .
+        "ÐÒÉÇÌÁÛÁÅÔ ×ÁÓ ÓÔÁÔØ ÞÌÅÎÏÍ ÓÏÏÂÝÅÓÔ×Á ÓÏ ÓÌÅÄÕÀÝÉÍÉ ÐÒÉ×ÉÌÅÇÉÑÍÉ:\n".
+        join(", ", map { $attr_map{$_} } @$attr) . ".\n\n" .
+        "åÓÌÉ ×Ù ÎÅ ÈÏÔÉÔÅ ÕÞÁÓÔ×Ï×ÁÔØ × $cuser, ÔÏ ÐÒÏÓÔÏ ÐÒÏÉÇÎÏÒÉÒÕÊÔÅ ÜÔÏ ÐÉÓØÍÏ.\n" .
+        "ïÄÎÁËÏ, ÅÓÌÉ ×Ù ÈÏÔÉÔÅ ÐÒÉÓÏÅÄÉÎÉÔØÓÑ Ë ÓÏÏÂÝÅÓÔ×Õ, ÔÏ, ÐÏÖÁÌÕÊÓÔÁ,\n" .
+        "ÐÅÒÅÊÄÉÔÅ ÐÏ ÓÓÙÌËÅ (ÎÉÖÅ × ÐÉÓØÍÅ), ÞÔÏÂÙ ÐÏÄÔ×ÅÒÄÉÔØ Ó×ÏÅ ÓÏÇÌÁÓÉÅ.\n\n" .
+        "     $LJ::SITEROOT/approve/$aa->{'aaid'}.$aa->{'authcode'}\n\n" .
+        "\nëÏÍÁÎÄÁ $LJ::SITENAME\n";
+
+    LJ::send_mail({
+        'to' => $u->{'email'},
+        'from' => $LJ::COMMUNITY_EMAIL,
+        'fromname' => $LJ::SITENAME,
+        'charset' => 'koi8-r',
+        'subject' => "þÌÅÎÓÔ×Ï × ÓÏÏÂÝÅÓÔ×Å: $cuser",
+        'body' => $body
+        });
+
+    return $aa;
+}
+
+
+1;

local/cgi-bin/communitylib.pl

@@ -0,0 +1,529 @@
+#!/usr/bin/perl
+
+package LJ;
+
+use strict;
+
+require "$ENV{'LJHOME'}/cgi-bin/communitylib-local.pl"
+    if -e "$ENV{'LJHOME'}/cgi-bin/communitylib-local.pl";
+
+# <LJFUNC>
+# name: LJ::get_sent_invites
+# des: Get a list of sent invitations from the past 30 days.
+# args: cuserid
+# des-cuserid: a userid or u object of the community to get sent invitations for
+# returns: hashref of arrayrefs with keys userid, maintid, recvtime, status, args (itself
+#   a hashref if what abilities the user would be given)
+# </LJFUNC>
+sub get_sent_invites {
+    my $cu = shift;
+    $cu = LJ::want_user($cu);
+    return undef unless $cu;
+
+    # now hit the database for their recent invites
+    my $dbcr = LJ::get_cluster_def_reader($cu);
+    return LJ::error('db') unless $dbcr;
+    my $data = $dbcr->selectall_arrayref('SELECT userid, maintid, recvtime, status, args FROM invitesent ' .
+                                         'WHERE commid = ? AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+                                          undef, $cu->{userid});
+
+    # now break data down into usable format for caller
+    my @res;
+    foreach my $row (@{$data || []}) {
+        my $temp = {};
+        LJ::decode_url_string($row->[4], $temp);
+        push @res, {
+            userid => $row->[0]+0,
+            maintid => $row->[1]+0,
+            recvtime => $row->[2],
+            status => $row->[3],
+            args => $temp,
+        };
+    }
+
+    # all done
+    return \@res;    
+}
+
+# <LJFUNC>
+# name: LJ::send_comm_invite
+# des: Sends an invitation to a user to join a community with the passed abilities.
+# args: uuserid, cuserid, muserid, attrs
+# des-uuserid: a userid or u object of the user to invite
+# des-cuserid: a userid or u object of the community to invite the user to
+# des-muserid: a userid or u object of the maintainer doing the inviting
+# des-attrs: a hashref of abilities this user should have (e.g. member, post, unmoderated, ...)
+# returns: 1 for success, undef if failure
+# </LJFUNC>
+sub send_comm_invite {
+    my ($u, $cu, $mu, $attrs) = @_;
+    $u = LJ::want_user($u);
+    $cu = LJ::want_user($cu);
+    $mu = LJ::want_user($mu);
+    return undef unless $u && $cu && $mu;
+
+    # step 1: if the user has banned the community, don't accept the invite
+    return LJ::error('comm_user_has_banned') if LJ::is_banned($cu, $u);
+
+    # step 2: outstanding invite?
+    my $dbcr = LJ::get_cluster_def_reader($u);
+    return LJ::error('db') unless $dbcr;
+    my $argstr = $dbcr->selectrow_array('SELECT args FROM inviterecv WHERE userid = ? AND commid = ? ' .
+                                        'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+                                        undef, $u->{userid}, $cu->{userid});
+
+    # step 3: exceeded outstanding invitation limit?  only if no outstanding invite
+    unless ($argstr) {
+        my $cdbcr = LJ::get_cluster_def_reader($cu);
+        return LJ::error('db') unless $cdbcr;
+        my $count = $cdbcr->selectrow_array("SELECT COUNT(*) FROM invitesent WHERE commid = ? AND userid <> ? AND status = 'outstanding'",
+                                            undef, $cu->{userid}, $u->{userid});
+        my $fr = LJ::get_friends($cu) || {};
+        my $max = int(scalar(keys %$fr) / 10); # can invite up to 1/10th of the community
+        $max = 50 if $max < 50;                # or 50, whichever is greater
+        return LJ::error('comm_invite_limit') if $count > $max;
+    }
+ 
+    # step 4: setup arg string as url-encoded string
+    my $newargstr = join('=1&', map { LJ::eurl($_) } @$attrs) . '=1';
+    
+    # step 5: delete old stuff (lazy cleaning of invite tables)
+    return LJ::error('db') unless $u->writer;
+    $u->do('DELETE FROM inviterecv WHERE userid = ? AND ' .
+           'recvtime < UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+           undef, $u->{userid});
+
+    return LJ::error('db') unless $cu->writer;
+    $cu->do('DELETE FROM invitesent WHERE commid = ? AND ' .
+            'recvtime < UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+            undef, $cu->{userid});
+
+    # step 6: branch here to update or insert
+    if ($argstr) {
+        # merely an update, so just do it quietly
+        $u->do("UPDATE inviterecv SET args = ? WHERE userid = ? AND commid = ?",
+               undef, $newargstr, $u->{userid}, $cu->{userid});
+
+        $cu->do("UPDATE invitesent SET args = ?, status = 'outstanding' WHERE userid = ? AND commid = ?",
+                undef, $newargstr, $cu->{userid}, $u->{userid});
+    } else {
+         # insert new data, as this is a new invite
+         $u->do("INSERT INTO inviterecv VALUES (?, ?, ?, UNIX_TIMESTAMP(), ?)",
+                undef, $u->{userid}, $cu->{userid}, $mu->{userid}, $newargstr);
+
+         $cu->do("REPLACE INTO invitesent VALUES (?, ?, ?, UNIX_TIMESTAMP(), 'outstanding', ?)",
+                 undef, $cu->{userid}, $u->{userid}, $mu->{userid}, $newargstr);
+    }
+
+    # step 7: error check database work
+    return LJ::error('db') if $u->err || $cu->err;
+
+    # create authaction and send email to user
+    LJ::comm_member_request($cu, $u, $attrs) if $LJ::LJR_EMAIL_COMM_INVITES;
+
+    # success
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::accept_comm_invite
+# des: Accepts an invitation a user has received.  This does all the work to make the
+#   user join the community as well as sets up privileges.
+# args: uuserid, cuserid
+# des-uuserid: a userid or u object of the user to get pending invites for
+# des-cuserid: a userid or u object of the community to reject the invitation from
+# returns: 1 for success, undef if failure
+# </LJFUNC>
+sub accept_comm_invite {
+    my ($u, $cu) = @_;
+    $u = LJ::want_user($u);
+    $cu = LJ::want_user($cu);
+    return undef unless $u && $cu;
+
+    # get their invite to make sure they have one
+    my $dbcr = LJ::get_cluster_def_reader($u);
+    return LJ::error('db') unless $dbcr;
+    my $argstr = $dbcr->selectrow_array('SELECT args FROM inviterecv WHERE userid = ? AND commid = ? ' .
+                                        'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+                                        undef, $u->{userid}, $cu->{userid});
+    return undef unless $argstr;
+
+    # decode to find out what they get
+    my $args = {};
+    LJ::decode_url_string($argstr, $args);
+
+    # valid invite.  let's accept it as far as the community listing us goes.
+    # 0, 0 means don't add comm to user's friends list, and don't auto-add P edge.
+    LJ::join_community($u, $cu, 0, 0) if $args->{member};
+    
+    # now grant necessary abilities
+    my %edgelist = (
+        post => 'P',
+        preapprove => 'N',
+        moderate => 'M',
+        admin => 'A',
+    );
+    foreach (keys %edgelist) {
+        LJ::set_rel($cu->{userid}, $u->{userid}, $edgelist{$_}) if $args->{$_};
+    }
+
+    # now we can delete the invite and update the status on the other side
+    return LJ::error('db') unless $u->writer;
+    $u->do("DELETE FROM inviterecv WHERE userid = ? AND commid = ?",
+           undef, $u->{userid}, $cu->{userid});
+
+    return LJ::error('db') unless $cu->writer;
+    $cu->do("UPDATE invitesent SET status = 'accepted' WHERE commid = ? AND userid = ?",
+            undef, $cu->{userid}, $u->{userid});
+
+    # done
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::reject_comm_invite
+# des: Rejects an invitation a user has received.
+# args: uuserid, cuserid
+# des-uuserid: a userid or u object of the user to get pending invites for
+# des-cuserid: a userid or u object of the community to reject the invitation from
+# returns: 1 for success, undef if failure
+# </LJFUNC>
+sub reject_comm_invite {
+    my ($u, $cu) = @_;
+    $u = LJ::want_user($u);
+    $cu = LJ::want_user($cu);
+    return undef unless $u && $cu;
+
+    # get their invite to make sure they have one
+    my $dbcr = LJ::get_cluster_def_reader($u);
+    return LJ::error('db') unless $dbcr;
+    my $test = $dbcr->selectrow_array('SELECT userid FROM inviterecv WHERE userid = ? AND commid = ? ' .
+                                      'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
+                                      undef, $u->{userid}, $cu->{userid});
+    return undef unless $test;
+
+    # now just reject it
+    return LJ::error('db') unless $u->writer;
+    $u->do("DELETE FROM inviterecv WHERE userid = ? AND commid = ?",
+              undef, $u->{userid}, $cu->{userid});
+
+    return LJ::error('db') unless $cu->writer;
+    $cu->do("UPDATE invitesent SET status = 'rejected' WHERE commid = ? AND userid = ?",
+            undef, $cu->{userid}, $u->{userid});
+
+    # done
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::get_pending_invites
+# des: Gets a list of pending invitations for a user to join a community.
+# args: uuserid
+# des-uuserid: a userid or u object of the user to get pending invites for
+# returns: [ [ commid, maintainerid, time, args(url encoded) ], [ ... ], ... ] or
+#   undef if failure
+# </LJFUNC>
+sub get_pending_invites {
+    my $u = shift;
+    $u = LJ::want_user($u);
+    return undef unless $u;
+
+    # hit up database for invites and return them
+    my $dbcr = LJ::get_cluster_def_reader($u);
+    return LJ::error('db') unless $dbcr;
+    my $pending = $dbcr->selectall_arrayref('SELECT commid, maintid, recvtime, args FROM inviterecv WHERE userid = ? ' .
+                                            'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))', 
+                                            undef, $u->{userid});
+    return undef if $dbcr->err;
+    return $pending;
+}
+
+# <LJFUNC>
+# name: LJ::leave_community
+# des: Makes a user leave a community.  Takes care of all reluser and friend stuff.
+# args: uuserid, ucommid, defriend
+# des-uuserid: a userid or u object of the user doing the leaving
+# des-ucommid: a userid or u object of the community being left
+# des-defriend: remove comm from user's friends list
+# returns: 1 if success, undef if error of some sort (ucommid not a comm, uuserid not in
+#   comm, db error, etc)
+# </LJFUNC>
+sub leave_community {
+    my ($uuid, $ucid, $defriend) = @_;
+    my $u = LJ::want_user($uuid);
+    my $cu = LJ::want_user($ucid);
+    $defriend = $defriend ? 1 : 0;
+    return LJ::error('comm_not_found') unless $u && $cu;
+
+    # defriend comm -> user
+    return LJ::error('comm_not_comm') unless $cu->{journaltype} =~ /[CS]/;
+    my $ret = LJ::remove_friend($cu->{userid}, $u->{userid});
+    return LJ::error('comm_not_member') unless $ret; # $ret = number of rows deleted, should be 1 if the user was in the comm
+
+    # clear edges that effect this relationship
+    foreach my $edge (qw(P N A M)) {
+        LJ::clear_rel($cu->{userid}, $u->{userid}, $edge);
+    }
+
+    # defriend user -> comm?
+    return 1 unless $defriend;
+    LJ::remove_friend($u, $cu);
+
+    # don't care if we failed the removal of comm from user's friends list...
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::join_community
+# des: Makes a user join a community.  Takes care of all reluser and friend stuff.
+# args: uuserid, ucommid, friend?, noauto?
+# des-uuserid: a userid or u object of the user doing the joining
+# des-ucommid: a userid or u object of the community being joined
+# des-friend: 1 to add this comm to user's friends list, else not
+# des-noauto: if defined, 1 adds P edge, 0 does not; else, base on community postlevel
+# returns: 1 if success, undef if error of some sort (ucommid not a comm, uuserid already in
+#   comm, db error, etc)
+# </LJFUNC>
+sub join_community {
+    my ($uuid, $ucid, $friend, $canpost) = @_;
+    my $u = LJ::want_user($uuid);
+    my $cu = LJ::want_user($ucid);
+    $friend = $friend ? 1 : 0;
+    return LJ::error('comm_not_found') unless $u && $cu;
+    return LJ::error('comm_not_comm') unless $cu->{journaltype} eq 'C';
+
+    # friend comm -> user
+    LJ::add_friend($cu->{userid}, $u->{userid});
+
+    # add edges that effect this relationship... if the user sent a fourth
+    # argument, use that as a bool.  else, load commrow and use the postlevel.
+    my $addpostacc = 0;
+    if (defined $canpost) {
+        $addpostacc = $canpost ? 1 : 0;
+    } else {
+        my $crow = LJ::get_community_row($cu);
+        $addpostacc = $crow->{postlevel} eq 'members' ? 1 : 0;
+    }
+    LJ::set_rel($cu->{userid}, $u->{userid}, 'P') if $addpostacc;
+
+    # friend user -> comm?
+    return 1 unless $friend;
+    LJ::add_friend($u->{userid}, $cu->{userid}, { defaultview => 1 });
+
+    # done
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::get_community_row
+# des: Gets data relevant to a community such as their membership level and posting access.
+# args: ucommid
+# des-ucommid: a userid or u object of the community
+# returns: a hashref with user, userid, name, membership, and postlevel data from the
+#   user and community tables; undef if error
+# </LJFUNC>
+sub get_community_row {
+    my $ucid = shift;
+    my $cu = LJ::want_user($ucid);
+    return unless $cu;
+
+    # hit up database
+    my $dbr = LJ::get_db_reader();
+    my ($membership, $postlevel) = 
+        $dbr->selectrow_array('SELECT membership, postlevel FROM community WHERE userid=?',
+                              undef, $cu->{userid});
+    return if $dbr->err;
+    return unless $membership && $postlevel;
+
+    # return result hashref
+    my $row = {
+        user => $cu->{user},
+        userid => $cu->{userid},
+        name => $cu->{name},
+        membership => $membership,
+        postlevel => $postlevel,
+    };
+    return $row;
+}
+
+# <LJFUNC>
+# name: LJ::get_pending_members
+# des: Gets a list of userids for people that have requested to be added to a community
+#   but haven't yet actually been approved or rejected.
+# args: comm
+# des-comm: a userid or u object of the community to get pending members of
+# returns: an arrayref of userids of people with pending membership requests
+# </LJFUNC>
+sub get_pending_members {
+    my $comm = shift;
+    my $cu = LJ::want_user($comm);
+    
+    # database request
+    my $dbr = LJ::get_db_reader();
+    my $args = $dbr->selectcol_arrayref('SELECT arg1 FROM authactions WHERE userid = ? ' .
+                                        "AND action = 'comm_join_request' AND used = 'N'",
+                                        undef, $cu->{userid}) || [];
+
+    # parse out the args
+    my @list;
+    foreach (@$args) {
+        push @list, $1+0 if $_ =~ /^targetid=(\d+)$/;
+    }
+    return \@list;
+}
+
+# <LJFUNC>
+# name: LJ::approve_pending_member
+# des: Approves someone's request to join a community.  This updates the authactions table
+#   as appropriate as well as does the regular join logic.  This also generates an email to
+#   be sent to the user notifying them of the acceptance.
+# args: commid, userid
+# des-commid: userid of the community
+# des-userid: userid of the user doing the join
+# returns: 1 on success, 0/undef on error
+# </LJFUNC>
+sub approve_pending_member {
+    my ($commid, $userid) = @_;
+    my $cu = LJ::want_user($commid);
+    my $u = LJ::want_user($userid);
+    return unless $cu && $u;
+
+    # step 1, update authactions table
+    my $dbh = LJ::get_db_writer();
+    my $count = $dbh->do("UPDATE authactions SET used = 'Y' WHERE userid = ? AND arg1 = ?",
+                         undef, $cu->{userid}, "targetid=$u->{userid}");
+    return unless $count;
+
+    # step 2, make user join the community
+    return unless LJ::join_community($u->{userid}, $cu->{userid});
+
+    # step 3, email the user
+    my $email = "Dear $u->{name},\n\n" .
+                "Your request to join the \"$cu->{user}\" community has been approved.  If you " .
+                "wish to add this community to your friends page reading list, click the link below.\n\n" .
+                "\t$LJ::SITEROOT/friends/add.bml?user=$cu->{user}\n\n" .
+                "Regards,\n$LJ::SITENAME Team";
+    LJ::send_mail({
+        to => $u->{email},
+        from => $LJ::COMMUNITY_EMAIL,
+        fromname => $LJ::SITENAME,
+        charset => 'utf-8',
+        subject => "Your Request to Join $cu->{user}",
+        body => $email,
+    });
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::reject_pending_member
+# des: Rejects someone's request to join a community.  Updates authactions and generates
+#   an email to the user.
+# args: commid, userid
+# des-commid: userid of the community
+# des-userid: userid of the user doing the join
+# returns: 1 on success, 0/undef on error
+# </LJFUNC>
+sub reject_pending_member {
+    my ($commid, $userid) = @_;
+    my $cu = LJ::want_user($commid);
+    my $u = LJ::want_user($userid);
+    return unless $cu && $u;
+
+    # step 1, update authactions table
+    my $dbh = LJ::get_db_writer();
+    my $count = $dbh->do("UPDATE authactions SET used = 'Y' WHERE userid = ? AND arg1 = ?",
+                         undef, $cu->{userid}, "targetid=$u->{userid}");
+    return unless $count;
+
+    # step 2, email the user
+    my $email = "Dear $u->{name},\n\n" .
+                "Your request to join the \"$cu->{user}\" community has been declined.  You " .
+                "may wish to contact the maintainer(s) of this community if you are still " .
+                "interested in joining.\n\n" .
+                "Regards,\n$LJ::SITENAME Team";
+    LJ::send_mail({
+        to => $u->{email},
+        from => $LJ::COMMUNITY_EMAIL,
+        fromname => $LJ::SITENAME,
+        charset => 'utf-8',
+        subject => "Your Request to Join $cu->{user}",
+        body => $email,
+    });
+    return 1;
+}
+
+# <LJFUNC>
+# name: LJ::comm_join_request
+# des: Registers an authaction to add a user to a
+#      community and sends an approval email to the maintainers
+# returns: Hashref; output of LJ::register_authaction()
+#          includes datecreate of old row if no new row was created
+# args: comm, u
+# des-comm: Community user object
+# des-u: User object to add to community
+# </LJFUNC>
+sub comm_join_request {
+    my ($comm, $u) = @_;
+    return undef unless ref $comm && ref $u;
+
+    my $arg = "targetid=$u->{userid}";
+    my $dbh = LJ::get_db_writer();
+
+    # check for duplicates within the same hour (to prevent spamming)
+    my $oldaa = $dbh->selectrow_hashref("SELECT aaid, authcode, datecreate FROM authactions " .
+                                        "WHERE userid=? AND arg1=? " .
+                                        "AND action='comm_join_request' AND used='N' " .
+                                        "AND NOW() < datecreate + INTERVAL 1 HOUR " .
+                                        "ORDER BY 1 DESC LIMIT 1",
+                                        undef, $comm->{'userid'}, $arg);
+    return $oldaa if $oldaa;
+
+    # insert authactions row
+    my $aa = LJ::register_authaction($comm->{'userid'}, 'comm_join_request', $arg);
+    return undef unless $aa;
+
+    # if there are older duplicates, invalidate any existing unused authactions of this type
+    $dbh->do("UPDATE authactions SET used='Y' WHERE userid=? AND aaid<>? AND arg1=? " .
+             "AND action='comm_invite' AND used='N'",
+             undef, $comm->{'userid'}, $aa->{'aaid'}, $arg);
+
+    # get maintainers of community
+    my $adminids = LJ::load_rel_user($comm->{userid}, 'A') || [];
+    my $admins = LJ::load_userids(@$adminids);
+
+    # now prepare the emails
+    my %dests;
+    my $cuser = $comm->{user};
+    foreach my $au (values %$admins) {
+        next if $dests{$au->{email}}++;
+        LJ::load_user_props($au, 'opt_communityjoinemail');
+        next if $au->{opt_communityjoinemail} =~ /[DN]/; # Daily, None
+        
+        my $body = "Dear $au->{name},\n\n" .
+                   "The user \"$u->{user}\" has requested to join the \"$cuser\" community.  If you wish " .
+                   "to add this user to your community, please click this link:\n\n" .
+                   "\t$LJ::SITEROOT/approve/$aa->{aaid}.$aa->{authcode}\n\n" .
+                   "Alternately, to approve or reject all outstanding membership requests at the same time, " .
+                   "visit the community member management page:\n\n" .
+                   "\t$LJ::SITEROOT/community/pending.bml?comm=$cuser\n\n" .
+                   "You may also ignore this e-mail.  The request to join will expire after a period of 30 days.\n\n" .
+                   "If you wish to no longer receive these e-mails, visit the community management page and " .
+                   "set the relevant options:\n\n\t$LJ::SITEROOT/community/manage.bml\n\n" .
+                   "Regards,\n$LJ::SITENAME Team\n";
+
+        LJ::send_mail({
+            to => $au->{email},
+            from => $LJ::COMMUNITY_EMAIL,
+            fromname => $LJ::SITENAME,
+            charset => 'utf-8',
+            subject => "$cuser Membership Request by $u->{user}",
+            body => $body,
+            wrap => 76,
+        });
+    }
+
+    return $aa;
+}
+
+
+1;

local/cgi-bin/console-local.pl

@@ -0,0 +1,738 @@
+use LJ::MemCache;
+use Golem;
+
+$cmd{'syn_delete'} = {
+    'handler' => \&syn_delete,
+    'privs' => [qw(syn_edit)],
+    'des' => "Deletes syndication. Totally.",
+    'argsummary' => '<username>',
+    'args' => [
+               'username' => "The username of the syndicated journal.",
+               ],
+    };
+
+$cmd{'accounts_by_ip'} = {
+    'handler' => \&accounts_by_ip,
+    'privs' => [qw(finduser)],
+    'des' => "Find accounts registered from given ip",
+    'argsummary' => '<ip>',
+    'args' => [
+               'ip' => "IP address or beginning of IP address",
+               ],
+    };
+
+$cmd{'expunge_user'} = {
+    'handler' => \&expunge_user,
+    'privs' => [qw(suspend)],
+    'des' => "Expunge malicious user products. For accounts with a lot of comments you might need to run this command several times.",
+    'argsummary' => '<username> <userid>',
+    'args' => [
+               'username' => "Malicious username",
+               'userid' => "Malicious userid (must match username)",
+               ],
+    };
+
+$cmd{'expunge_anonymous_comments'} = {
+    'handler' => \&expunge_anonymous_comments,
+    'privs' => [qw(suspend)],
+    'des' => "Expunge all anonymous comments for a given post.",
+    'argsummary' => '<username> <itemid> <talkid>',
+    'args' => [
+               'username' => "The username of the journal comment is in",
+               'itemid' => "The itemid of the post to have a comment deleted from it",
+               'talkid' => "delete comments starting this thread, 0 for all",
+
+                   # note: the ditemid, actually, but that's too internals-ish?
+               ],
+     };
+
+
+$cmd{'ljr_fif'} = {
+    'handler' => \&ljr_fif,
+    'privs' => [qw(siteadmin)],
+    'des' => "ljr_fif manipulation.",
+    'argsummary' => 'add|delete|list_excluded [<username>]',
+    'args' => [
+               'username' => "The username.",
+               ],
+    };
+
+$cmd{'net'} = {
+    'handler' => \&net,
+    'privs' => [qw(siteadmin)],
+    'des' => "ip blocks manipulation.",
+    'argsummary' => 'add [CIDR] name|delete <CIDR>|ban_new_accounts <CIDR>|ban_comments <CIDR>|list',
+    'args' => [
+               'username' => "The username.",
+               ],
+    };
+
+sub net {
+		my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+
+    return $err->("This command needs at least 1 argument.")
+      if @$args < 1;
+	
+    return $err->("Golem is not plugged-into this site.")
+      unless $Golem::on;
+
+    my $action = $args->[1];
+    my $cidr = $args->[2];
+
+    my $net_list = sub {
+      my $dbr = LJ::get_db_reader();
+      return $err->("Can't get database reader!") unless $dbr;
+    
+      my $sth = $dbr->prepare("select net_v4.* from net_v4");
+      $sth->execute();
+      die $dbr->errstr if $dbr->err;
+    
+      push @$out, [ '', "Known ip_v4 networks" ];
+      while (my $row = $sth->fetchrow_hashref) {
+      	my $tnet = Golem::get_net_by_id($row->{'id'}, {"with_props" => 1});
+
+      	my $str = $tnet->{'net_with_mask'} . " [" . $row->{'name'} . "]";
+
+    		if ($tnet->{'props'}->{'data'}->{'ban_new_accounts'}) {
+    			$str .= ", ban_new_accounts";
+    		}
+    		if ($tnet->{'props'}->{'data'}->{'ban_comments'}) {
+					$str .= ", ban_comments in ";
+    			foreach my $userid (keys %{$tnet->{'props'}->{'data'}->{'ban_comments'}}) {
+    				next unless $userid;
+
+    				my $u = LJ::load_userid($userid);
+    				if ($u) {
+    					$str .= $u->{'user'} . ",";
+    				}
+    				else {
+    					$str .= $userid . " (user does not exist),";
+    				}
+    			}
+    			chop($str);
+    		}
+
+        push @$out, [ '', $str ];
+      }
+    };
+
+    if ($action eq "list") {
+    	$net_list->();
+    }
+    else {
+      my $start_ip = $cidr;
+      $start_ip =~ s/\/.+//o;
+
+      my $net_mask;
+      if ($cidr =~ /\//o) {
+      	$net_mask = $cidr;
+	      $net_mask =~ s/.+\///o;
+	    }
+
+      if (!$net_mask) {
+	      $net_mask = "32";
+	      push @$out, ['', "Netmask not specified, assuming /32"];
+	    }
+
+      return $err->("Invalid CIDR format. Required: 1.2.3.4/32")
+  			unless $start_ip && $net_mask;
+
+  		return $err->("Invalid IP address.")
+  			unless Golem::is_ipv4($start_ip);
+
+  		if ($action eq "add") {
+  			my $name;
+  			my $j = 3;
+  			while ($args->[$j]) {
+  				$name .= $args->[$j] . " ";
+  				$j++;
+  			}
+  			chop($name) if $name;
+
+  			return $err->("Please specify some net details")
+  				unless $name;
+
+  			my $sip = Golem::ipv4_str2int($start_ip);
+  			my $eip = $sip + Golem::ipv4_mask2offset($net_mask);
+			
+			if ($eip - $sip > 10000) {
+			  return $err->("IP block should be less than 10000 addresses.");
+			}
+
+  			for (my $i = $sip; $i <= $eip; $i++) {
+  				my $tnet = Golem::get_containing_net($i);
+  				if (!$tnet) {
+  					$tnet = Golem::get_net($i, "32");
+  				}
+
+  				if ($tnet) {
+  					return $err->("IP [" .
+  						Golem::ipv4_int2str($i) .
+  						"] is already contained in net [" . $tnet->{'ip_str'} . "/" . $tnet->{'mask'} . "]\n");
+  				}
+  			}
+
+  			my $tnet = Golem::insert_net({
+		      "ip_str" => $start_ip,
+    		  "mask" => $net_mask,
+      		"name" => $name
+		      });
+
+  			if ($tnet && !$tnet->{'err'}) {
+	  			push @$out, ['', "Created net [" . $tnet->{'ip_str'} . "/" . $tnet->{'mask'} . "]\n"];
+					
+					$net_list->();
+	  		}
+	  		else {
+	  			return $err->("Error creating net: " . $tnet->{'errstr'});
+	  		}
+  		}
+  		elsif ($action eq "delete") {
+  			my $tnet = Golem::get_net($start_ip, $net_mask);
+  			if ($tnet) {
+  				my $r = Golem::delete_net($tnet);
+  				if ($r && !$r->{'err'}) {
+  					push @$out, ['', "Deleted net [$start_ip/$net_mask]\n"];
+
+  					$net_list->();
+  				}
+  				else {
+  					return $err->("Error deleting net: " . $r->{'errstr'});
+  				}
+  			}
+  			else {
+  				return $err->("Net [$start_ip/$net_mask] does not exist.");
+  			}
+  		}
+  		elsif ($action eq "ban_new_accounts") {
+  			my $tnet = Golem::get_net($start_ip, $net_mask, {"with_props" => 1});
+  			if ($tnet) {
+  				$tnet->{'props'}->{'data'}->{'ban_new_accounts'} = 1;
+  				$tnet = Golem::save_net($tnet);
+
+  				if ($tnet && $tnet->{'err'}) {
+  					return $err->("Error saving net [$start_ip/$net_mask]: " . $tnet->{'errstr'});
+  				}
+  				else {
+  					$net_list->();
+  				}
+  			}
+  			else {
+  				return $err->("Net [$start_ip/$net_mask] does not exist.");
+  			}
+  		}
+  		elsif ($action eq "ban_comments") {
+  			my $u = LJ::load_user($args->[3]);
+  			return $err->("ban_comments needs username as last parameter")
+  				unless $u;
+
+  			my $tnet = Golem::get_net($start_ip, $net_mask, {"with_props" => 1});
+  			if ($tnet) {
+  				$tnet->{'props'}->{'data'}->{'ban_comments'} = {}
+  					unless defined($tnet->{'props'}->{'data'}->{'ban_comments'});
+
+  				$tnet->{'props'}->{'data'}->{'ban_comments'}->{$u->{'userid'}} = time();
+  				$tnet = Golem::save_net($tnet);
+
+  				if ($tnet && $tnet->{'err'}) {
+  					return $err->("Error saving net [$start_ip/$net_mask]: " . $tnet->{'errstr'});
+  				}
+  				else {
+  					$net_list->();
+  				}
+  			}
+  			else {
+  				return $err->("Net [$start_ip/$net_mask] does not exist.");
+  			}
+  		}
+		}
+    
+    return 1;
+}
+
+
+sub expunge_user {
+    my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+    my $do_out = sub { push @$out, [ "", $_[0] ]; 1; };
+
+    return $err->("This command takes 2 arguments") unless @$args eq 3;
+    return $err->("You are not authorized to use this command.")
+        unless ($remote && $remote->{'priv'}->{'suspend'});
+
+    my $in_user = $args->[1];
+    my $in_userid = $args->[2];
+
+    my $u = LJ::load_user($in_user);
+    return $err->("Supplied userid doesn't match user name.")
+      unless $u->{'userid'} eq $in_userid;
+
+    # copied from delete_all_comments (from talklib.pl)
+    my $dbcm = LJ::get_cluster_master($u);
+    return 0 unless $dbcm && $u->writer;
+
+    my ($t, $loop) = (undef, 1);
+    my $chunk_size = 200;
+
+    my %affected_journals;
+    my $n = 0;
+
+    while ($loop &&
+      ($t = $dbcm->selectrow_arrayref("SELECT journalid, jtalkid, nodetype, nodeid, state FROM talk2 WHERE ".
+                                      "posterid=? LIMIT $chunk_size", undef, $u->{'userid'}))
+       && $t && @$t)
+    {
+        my @processed = @$t;
+        while(@processed) {
+          my $state = pop @processed;
+          my $nodeid = pop @processed;
+          my $nodetype = pop @processed;
+          my $jtalkid = pop @processed;
+          my $journalid = pop @processed;
+
+          $affected_journals{$journalid} = 1;
+          $n++;
+
+          foreach my $table (qw(talkprop2 talktext2 talk2)) {
+            $u->do("DELETE FROM $table WHERE journalid=? AND jtalkid=?",
+                   undef, $journalid, $jtalkid);
+          }
+          # (NB!) slow and suboptimal
+          # (NB!) replycount will be updated on demand
+          # (Sic!) may break threads consistency!!!
+
+          my $memkey = [$journalid, "talk2:$journalid:$nodetype:$nodeid"];
+          LJ::MemCache::delete($memkey);
+
+          my $tu = LJ::load_userid($journalid);
+          LJ::Talk::update_commentalter($tu, $nodeid);
+        }
+    }
+
+    foreach my $j (keys %affected_journals) {
+      my $tu = LJ::load_userid($j);
+      LJ::wipe_major_memcache($tu); # is it ever needed?
+    }
+    my $m = scalar keys %affected_journals;
+
+    $do_out->("$in_user: $n comments expunged from $m journals.");
+}
+
+sub expunge_anonymous_comments {
+    my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+    my $do_out = sub { push @$out, [ "", $_[0] ]; 1; };
+
+    return $err->("This command takes 3 arguments") unless @$args eq 4;
+    return $err->("You are not authorized to use this command.")
+        unless ($remote && $remote->{'priv'}->{'suspend'});
+
+    my $in_user = $args->[1];
+
+    my $dtalkid = $args->[3]+0;
+    my $jtalkid_min = $dtalkid >> 8;
+
+    my $ditemid = $args->[2]+0;
+    my $jitemid = $ditemid >> 8;
+    my $nodetype = 'L';
+
+    my $u = LJ::load_user($in_user);
+    return $err->("Supplied userid doesn't exists.")
+      unless $u;
+
+    my $dbcm = LJ::get_cluster_master($u);
+    return 0 unless $dbcm && $u->writer;
+
+    my $journalid = $u->{'userid'};
+    my $nodeid = $jitemid;
+    $jtalkid_min--; #start from this
+
+    # see also delete_all_comments (from talklib.pl) for right sql request
+    my $t = $dbcm->selectcol_arrayref("SELECT jtalkid FROM talk2 WHERE ".
+                      "journalid=? AND nodeid=? ".
+                      "AND posterid=0 AND jtalkid>?",
+                       undef,
+                       $journalid, $nodeid, $jtalkid_min);
+    return 0 unless $t;
+
+    my $num = LJ::Talk::delete_comments($u, $nodetype, $jitemid, $t);
+
+    LJ::MemCache::delete([$journalid, "talk2:$journalid:$nodetype:$nodeid"]);
+    LJ::MemCache::delete([$journalid, "talk2ct:$journalid"]);
+
+    $do_out->("$num anonymous comments deleted.");
+
+    return 1;
+}
+
+sub accounts_by_ip {
+    my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+    my $do_out = sub { push @$out, [ "", $_[0] ]; 1; };
+    
+    return $err->("This command takes 1 argument") unless @$args eq 2;
+    return $err->("You are not authorized to use this command.")
+        unless ($remote && $remote->{'priv'}->{'finduser'});
+
+    my $ip = $args->[1];
+    
+    my $dbr = LJ::get_db_reader();
+    return $err->("Can't get database reader!") unless $dbr;
+
+    my $sth = $dbh->prepare("SELECT userid, ip, FROM_UNIXTIME(logtime) FROM userlog where action = 'account_create' and ip like ?");
+    $sth->execute($ip . "%");
+    die $dbh->errstr if $dbh->err;
+    
+    while (my @row = $sth->fetchrow_array) {
+      my $userid = $row[0];
+      my $tip = $row[1];
+      my $date = $row[2];
+      my $u = LJ::load_userid($userid);
+      my $user = $u->{'user'}; 
+      my $status = $u->{'statusvis'};
+
+      $do_out->("$user $tip $date $status");
+    }
+    return 1;
+}
+
+sub syn_delete
+{
+    my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+
+    return $err->("This command has 1 argument") unless @$args == 2;
+
+    return $err->("You are not authorized to use this command.")
+        unless ($remote && $remote->{'priv'}->{'syn_edit'});
+
+    my $user = $args->[1];
+    my $u = LJ::load_user($user);
+    my $du = $u;
+    my $uid = $u->{'userid'};
+
+    return $err->("Invalid user $user") unless $u;
+    return $err->("Not a syndicated account") unless $u->{'journaltype'} eq 'Y';
+
+    # copied from bin/deleteusers.pl
+    my $runsql = sub {
+        my $db = $dbh;
+        if (ref $_[0]) { $db = shift; }
+        my $user = shift;
+        my $sql = shift;
+        $db->do($sql);
+        return ! $db->err;
+    };
+    
+    my $dbcm = LJ::get_cluster_master($du);
+
+    # delete userpics
+    {
+        if ($du->{'dversion'} > 6) {
+            $ids = $dbcm->selectcol_arrayref("SELECT picid FROM userpic2 WHERE userid=$uid");
+        } else {
+            $ids = $dbh->selectcol_arrayref("SELECT picid FROM userpic WHERE userid=$uid");
+        }
+  my $in = join(",",@$ids);
+  if ($in) {
+      $runsql->($dbcm, $user, "DELETE FROM userpicblob2 WHERE userid=$uid AND picid IN ($in)");
+            if ($du->{'dversion'} > 6) {
+                
+                return $err->("error deleting from userpic2: " . $dbh->errstr)
+                  unless $runsql->($dbcm, $user, "DELETE FROM userpic2 WHERE userid=$uid");
+
+                return $err->("error deleting from userpicmap2: " . $dbh->errstr)
+                  unless $runsql->($dbcm, $user, "DELETE FROM userpicmap2 WHERE userid=$uid");
+
+                return $err->("error deleting from userkeywords: " . $dbh->errstr)
+                  unless $runsql->($dbcm, $user, "DELETE FROM userkeywords WHERE userid=$uid");
+            } else {
+                return $err->("error deleting from userpic: " . $dbh->errstr)
+                  unless $runsql->($dbh, $user, "DELETE FROM userpic WHERE userid=$uid");
+
+                return $err->("error deleting from userpicmap: " . $dbh->errstr)
+                  unless $runsql->($dbh, $user, "DELETE FROM userpicmap WHERE userid=$uid");
+            }
+  }
+    }
+
+
+    # delete posts
+    while (($ids = $dbcm->selectall_arrayref("SELECT jitemid, anum FROM log2 WHERE journalid=$uid LIMIT 100")) && @{$ids})
+    {
+  foreach my $idanum (@$ids) {
+      my ($id, $anum) = ($idanum->[0], $idanum->[1]);
+      LJ::delete_entry($du, $id, 0, $anum);
+  }
+    }
+
+    # misc:
+    $runsql->($user, "DELETE FROM userusage WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM friends WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM friends WHERE friendid=$uid");
+    $runsql->($user, "DELETE FROM friendgroup WHERE userid=$uid");
+    $runsql->($dbcm, $user, "DELETE FROM friendgroup2 WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM memorable WHERE userid=$uid");
+    $runsql->($dbcm, $user, "DELETE FROM memorable2 WHERE userid=$uid");
+    $runsql->($dbcm, $user, "DELETE FROM userkeywords WHERE userid=$uid");
+    $runsql->($dbcm, $user, "DELETE FROM memkeyword2 WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM userbio WHERE userid=$uid");
+    $runsql->($dbcm, $user, "DELETE FROM userbio WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM userinterests WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM userprop WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM userproplite WHERE userid=$uid");   
+    $runsql->($user, "DELETE FROM txtmsg WHERE userid=$uid");   
+    $runsql->($user, "DELETE FROM overrides WHERE user='$du->{'user'}'");
+    $runsql->($user, "DELETE FROM priv_map WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM infohistory WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM reluser WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM reluser WHERE targetid=$uid");
+    $runsql->($user, "DELETE FROM userlog WHERE userid=$uid");
+    $runsql->($user, "DELETE FROM syndicated WHERE userid=$uid");
+
+    return $err->("error updating user uid $uid: " . $dbh->errstr)
+      unless $runsql->($user, "UPDATE user SET statusvis='X', statusvisdate=NOW(), password='' WHERE userid=$uid");
+
+    push @$out, [ '', "Deleted syndication accout $user." ];
+    # log to statushistory
+    LJ::statushistory_add($u->{userid}, $remote->{userid}, 'synd_delete',
+                          "Syndication deleted.");
+        
+    LJ::MemCache::set("uidof:$user", "");
+    return 1;
+}
+
+
+sub ljr_fif
+{
+    my ($dbh, $remote, $args, $out) = @_;
+    my $err = sub { push @$out, [ "error", $_[0] ]; 0; };
+
+    return $err->("This command needs at least 1 argument.")
+      if @$args != 2 && @$args != 3;
+	
+    return $err->("LJR_FIF is not configured for this site.")
+      unless $LJ::LJR_FIF;
+
+    my $action = $args->[1];
+    my $user = $args->[2];
+    
+    my $fifid = LJ::get_userid($LJ::LJR_FIF);
+    return $err->("Invalid fif $LJ::LJR_FIF") unless $fifid;
+    
+    if ($action eq "list_excluded") {
+      my $dbr = LJ::get_db_reader();
+      return $err->("Can't get database reader!") unless $dbr;
+
+      my $sth = $dbr->prepare("select user.*, friends.userid
+        from user left outer join friends on
+            friends.userid = ? and
+            friends.friendid = user.userid
+	where
+	  user.userid < ? and
+	  user.journaltype <> 'I' and
+	  user.journaltype <> 'Y' and
+	  friends.userid IS NULL;
+        ");
+      $sth->execute($fifid, $LJ::LJR_IMPORTED_USERIDS);
+      die $dbr->errstr if $dbr->err;
+    
+      push @$out, [ '', "Excluded from ljr_fif friends" ];
+      while (my $row = $sth->fetchrow_hashref) {
+        push @$out, [ '', $row->{'user'} ];
+      }
+    }
+    else {
+
+      return $err->("You are not authorized to use this command.")
+        unless ($remote && $remote->{'priv'}->{'siteadmin'});
+
+      my $userid = LJ::get_userid($user);
+      return $err->("Invalid user $user") unless $userid;
+    
+      my $action_text;
+      if ($action eq "add") {
+        LJ::add_friend($fifid, $userid);
+        $action_text = "Added $user to";
+      }
+      elsif ($action eq "delete") {
+        LJ::remove_friend($fifid, $userid);
+        $action_text = "Deleted $user from";
+      }
+
+      push @$out, [ '', "$action_text ljr_fif friends." ];
+    }
+    
+    return 1;
+}
+
+
+$cmd{'twit_set'} = {
+    'handler' => \&twit_set,
+    'des' => 'If you twit somebody you won\'t see his/her entries in ljr-fif.',
+    'argsummary' => '<user>',
+    'args' => [
+               'user' => "This is the user you don't want to see in ljr-fif.",
+               ],
+    };
+
+$cmd{'twit_unset'} = {
+    'handler' => \&twit_set,
+    'des' => 'Remove twit on a user.',
+    'argsummary' => '<user>',
+    'args' => [
+               'user' => "The user's entries will be seen in ljr-fif.",
+               ],
+    };
+   
+$cmd{'twit_list'} = {
+    'handler' => \&twit_list,
+    'des' => 'List your twits (the users you don\'t see in ljr_fif).',
+    'argsummary' => '[ <user> ]',
+    'args' => [
+               'user' => "Optional; list twits for any user if you have the 'finduser' priv. (this admin-only feature is broken right now)",
+               ],
+    };
+
+
+sub twit_list
+{
+    my ($dbh, $remote, $args, $out) = @_;
+
+    unless ($remote) {
+        push @$out, [ "error", "You must be logged in to use this command." ];
+        return 0;
+    }
+
+    # journal to list from
+    my $j = $remote;
+
+    unless ($remote->{'journaltype'} eq "P") {
+        push @$out, [ "error", "You're not logged in as a person account." ];
+        return 0;
+    }
+    
+    my $twitedids = load_twit($j->{userid}) || [];
+    my $us = LJ::load_userids(@$twitedids);
+    my @userlist = map { $us->{$_}{user} } keys %$us;
+ 
+    foreach my $username (@userlist) {
+        push @$out, [ 'info', $username ];
+    }
+    push @$out, [ "info", "$j->{user} has not twitted any other users." ] unless @userlist;
+    return 1;
+}
+
+sub twit_set
+{
+    my ($dbh, $remote, $args, $out) = @_;
+    my $error = 0;
+
+    unless ($remote) {
+        push @$out, [ "error", "You must be logged in to use this command" ];
+        return 0;
+    }
+
+    # journal to ban from:
+    my $j;
+
+    unless ($remote->{'journaltype'} eq "P") {
+        push @$out, [ "error", "You're not logged in as a person account." ],
+        return 0;
+    }
+
+    $j = $remote;
+    
+    my $user = $args->[1];
+    my $twitid = LJ::get_userid($dbh, $user);
+
+    unless ($twitid) {
+        $error = 1;
+        push @$out, [ "error", "Invalid user \"$user\"" ];
+    }
+    
+    return 0 if ($error);    
+
+    my $qtwitid = $twitid+0;
+    my $quserid = $j->{'userid'}+0;
+
+    # exceeded twit limit?
+    if ($args->[0] eq 'twit_set') {
+        my $twitlist = load_twit($j->{userid}) || [];
+        if (scalar(@$twitlist) >= ($LJ::MAX_BANS || 5000)) {
+            push @$out, [ "error", "You have reached the maximum number of twits.  Sorry." ];
+            return 0;
+        }
+    }
+
+    if ($args->[0] eq "twit_set") {
+        twit_rel_set($j->{userid}, $twitid);
+        $j->log_event('twit_set', { actiontarget => $twitid, remote => $remote });
+	if (!LJ::check_twit($j->{userid},$twitid)) {
+	    push @$out, [ "error", 
+                     "An error occured!\n" . 
+                "User $user ($twitid) is not twitted by $j->{'user'}." ];
+	    return 0; 
+	}
+        push @$out, [ "info", "User $user ($twitid) twitted by $j->{'user'}." ];
+        return 1;
+    }
+
+    if ($args->[0] eq "twit_unset") {
+        twit_rel_unset($j->{userid}, $twitid);
+        $j->log_event('twit_unset', { actiontarget => $twitid, remote => $remote });
+	if (LJ::check_twit($j->{userid},$twitid)) {
+	    push @$out, [ "error", 
+                     "An error occured!\n" . 
+                "User $user ($twitid) is still twitted by $j->{'user'}." ];
+	    return 0; 
+	}
+        push @$out, [ "info", "User $user ($twitid) is not twitted by $j->{'user'} in ljr-fif." ];
+        return 1;
+    }
+
+    return 0;
+}
+
+
+# des: Load user twits table
+# UNCLUSTERED! Should be rewritten if we are going clusered
+# args: userid
+sub load_twit
+{
+    my $userid = $_[0];
+    return undef unless $userid;
+    my $u = LJ::want_user($userid);
+    $userid = LJ::want_userid($userid);
+    $db = LJ::get_db_reader();
+    return $err->("Can't get database reader!") unless $db;
+    return $db->selectcol_arrayref("SELECT twitid FROM 
+           twits WHERE userid=?",  undef, $userid);
+}
+
+# des: Add the second user to the twit list of the first
+# UNCLUSTERED! Should be rewritten if we are going clusered
+# args: userid, twitid
+sub twit_rel_set
+{
+    my ($userid,$twitid) = @_;
+    return undef unless $userid;     return undef unless $twitid;
+    $db = LJ::get_db_writer();
+    return $err->("Can't get database reader!") unless $db;
+    $db->do("INSERT INTO twits VALUES ($userid, $twitid)");
+}
+
+# des: Remove the second user from the twit list of the first
+# UNCLUSTERED! Should be rewritten if we are going clusered
+# args: userid, twitid
+sub twit_rel_unset
+{
+    my ($userid,$twitid) = @_;
+    return undef unless $userid;     return undef unless $twitid;
+    $db = LJ::get_db_writer();
+    return $err->("Can't get database reader!") unless $db;
+    $db->do("DELETE FROM twits WHERE userid=$userid AND twitid=$twitid");
+}
+
+return 1;

local/cgi-bin/consuspend.pl

@@ -0,0 +1,457 @@
+#!/usr/bin/perl
+#
+
+package LJ::Con;
+
+use strict;
+use vars qw(%cmd);
+
+$cmd{'expunge_userpic'}->{'handler'} = \&expunge_userpic;
+$cmd{'suspend'}->{'handler'} = \&suspend;
+$cmd{'unsuspend'}->{'handler'} = \&suspend;
+$cmd{'getemail'}->{'handler'} = \&getemail;
+$cmd{'get_maintainer'}->{'handler'} = \&get_maintainer;
+$cmd{'get_moderator'}->{'handler'} = \&get_moderator;
+$cmd{'finduser'}->{'handler'} = \&finduser;
+$cmd{'infohistory'}->{'handler'} = \&infohistory;
+$cmd{'change_journal_status'}->{'handler'} = \&change_journal_status;
+$cmd{'set_underage'}->{'handler'} = \&set_underage;
+
+sub set_underage {
+    my ($dbh, $remote, $args, $out) = @_;
+
+    my $err = sub { push @$out, [ "error", shift ]; 0; };
+    my $info = sub { push @$out, [ "info", shift ]; 1; };
+
+    return $err->("This command takes three arguments.  Consult the reference for details.")
+        unless scalar(@$args) == 4;
+    return $err->("You don't have the necessary privilege (siteadmin:underage) to change an account's underage flag.")
+        unless LJ::check_priv($remote, 'siteadmin', 'underage') || LJ::check_priv($remote, 'siteadmin', '*');
+
+    my $u = LJ::load_user($args->[1]);
+    return $err->("Invalid user.")
+        unless $u;
+    return $err->("Account is not a person type account.")
+        unless $u->{journaltype} eq 'P';
+
+    return $err->("Second argument must be 'on' or 'off'.")
+        unless $args->[2] =~ /^(?:on|off)$/;
+    my $on = $args->[2] eq 'on' ? 1 : 0;
+
+    my $note = $args->[3];
+    return $err->("You must provide a reason for this change as the third argument.")
+        unless $note;
+
+    # can't set state to what it is already
+    return $err->("User is already of the requested underage state.")
+        unless $on ^ $u->underage;
+
+    my ($res, $sh, $status);
+    if ($on) {
+        $status = 'M'; # "M"anually turned on
+        $res = "User marked as underage.";
+        $sh = "marked; $note";
+    } else {
+        $status = undef; # no status change
+        $res = "User no longer marked as underaged.";
+        $sh = "unmarked; $note";
+    }
+
+    # now record this change (yes we log it twice)
+    LJ::statushistory_add($u->{userid}, $remote->{userid}, "set_underage", $sh);
+    $u->underage($on, $status, "manual");
+    return $info->($res);
+}
+
+sub change_journal_status {
+    my ($dbh, $remote, $args, $out) = @_;
+
+    my $err = sub { push @$out, [ "error", shift ]; 0; };
+    my $info = sub { push @$out, [ "info", shift ]; 1; };
+
+    return $err->("This command takes two arguments.  Consult the reference for details.")
+        unless scalar(@$args) == 3;
+    return $err->("You don't have the necessary privilege (siteadmin:users) to change account status.")
+        unless LJ::check_priv($remote, 'siteadmin', 'users') || LJ::check_priv($remote, 'siteadmin', '*');
+
+    my $u = LJ::load_user($args->[1]);
+    return $err->("Invalid user.")
+        unless $u;
+
+    # figure out the new status
+    my $status = $args->[2];
+    my $opts = {
+        #name  =>   [ 'status-to', 'valid-statuses-from', 'error-message-if-from-fails', 'success-message' ]
+        normal =>   [ 'V', 'ML', 'The user must be in memorial or locked status first.', 'User status set back to normal.' ],
+        memorial => [ 'M', 'V', 'The user must be in normal status first.', 'User account set as memorial.' ],
+        locked =>   [ 'L', 'V', 'The user must be in normal status first.', 'User account has been locked.' ],
+    }->{$status};
+
+    # make sure we got a valid $opts arrayref
+    return $err->("Invalid status.  Consult the reference for more information.")
+        unless defined $opts && ref $opts eq 'ARRAY';
+
+    # verify user's from-statusvis is okay (it's contained in $opts->[1])
+    return $err->($opts->[2]) unless $opts->[1] =~ /$u->{statusvis}/;
+
+    # okay, so we need to update the user now and update statushistory
+    LJ::statushistory_add($u->{userid}, $remote->{userid}, "journal_status", "Changed status to $status from $u->{statusvis}.");
+    LJ::update_user($u->{'userid'}, { statusvis => $opts->[0], raw => 'statusvisdate=NOW()' });
+    return $info->($opts->[3]);
+}
+
+sub expunge_userpic {
+    my ($dbh, $remote, $args, $out) = @_;
+
+    unless (scalar(@$args) == 3) {
+        push @$out, [ "error", "This command takes exactly two arguments, username and picid.  Consult the reference." ];
+        return 0;
+    }
+
+    my $user = $args->[1];
+    my $picid = $args->[2]+0;
+
+    unless (LJ::check_priv($remote, 'siteadmin', 'userpics') || LJ::check_priv($remote, 'siteadmin', '*')) {
+        push @$out, [ "error", "You don't have access to expunge user picture icons." ];
+        return 0;
+    }
+
+    my $u = LJ::load_user($user);
+
+    # the actual expunging happens in ljlib
+    my ($rval, $hookval) = LJ::expunge_userpic($u, $picid);
+    push @$out, $hookval if @{$hookval || []};
+
+    # now load up from the return value we got
+    unless ($rval && $u) {
+        push @$out, [ "error", "Error expunging user picture icon." ];
+        return 0;
+    }
+
+    # but make sure to log it
+    LJ::statushistory_add($u->{userid}, $remote->{userid}, 'expunge_userpic', "expunged userpic; id=$picid");
+    push @$out, [ "info", "User picture icon $picid for $u->{user} expunged from $LJ::SITENAMESHORT." ];
+
+    return 1;
+}
+
+sub suspend
+{
+    my ($dbh, $remote, $args, $out) = @_;
+
+    my $confirmed = 0;
+    if (scalar(@$args) == 4 && $args->[3] eq 'confirm') {
+        pop @$args;
+        $confirmed = 1;
+    }
+
+    unless (scalar(@$args) == 3) {
+        push @$out, [ "error", "This command takes exactly 2 arguments.  Consult the reference." ];
+        return 0;
+    }
+
+    my $cmd = $args->[0];
+    my ($user, $reason) = ($args->[1], $args->[2]);
+
+    if ($cmd eq "suspend" && $reason eq "off") {
+        push @$out, [ "error", "The second argument to the 'suspend' command is no longer 'off' to unsuspend.  Use the 'unsuspend' command instead." ];
+        return 0;
+    }
+
+    unless ($remote->{'priv'}->{'suspend'}) {
+        push @$out, [ "error", "You don't have access to $cmd users." ];
+        return 0;
+    }
+
+    # if the user argument is an email address...
+    my @users;
+    if ($user =~ /@/) {
+        push @$out, [ "info", "Acting on users matching email $user..." ];
+
+        my $dbr = LJ::get_db_reader();
+        my $names = $dbr->selectcol_arrayref('SELECT user FROM user WHERE email = ?', undef, $user);
+        if ($dbr->err) {
+            push @$out, [ "error", "Database error: " . $dbr->errstr ];
+            return 0;
+        }
+        unless ($names && @$names) {
+            push @$out, [ "error", "No users found matching the email address $user." ];
+            return 0;
+        }
+
+        # bail unless they've confirmed this mass action
+        unless ($confirmed) {
+            push @$out, [ "info", "    $_" ] foreach @$names;
+            push @$out, [ "info", "To actually confirm this action, please do this again:" ];
+            push @$out, [ "info", "    $cmd $user \"$reason\" confirm" ];
+            return 1;
+        }
+
+        push @users, $_ foreach @$names;
+    } else {
+        push @users, $user;
+    }
+
+    foreach my $username (@users) {
+        my $u = LJ::load_user($username);
+        unless ($u) {
+            push @$out, [ "error", "$username invalid/unable to load." ];
+            next;
+        }
+
+        my $status = ($cmd eq "unsuspend") ? "V" : "S";
+        if ($u->{'statusvis'} eq $status) {
+            push @$out, [ "error", "$username was already in that state ($status)" ];
+            next;
+        }
+
+        LJ::update_user($u->{'userid'}, { statusvis => $status, raw => 'statusvisdate=NOW()' });
+        $u->{statusvis} = $status;
+
+        LJ::statushistory_add($u->{'userid'}, $remote->{'userid'}, $cmd, $reason);
+
+        LJ::Con::fb_push( $u );
+
+        push @$out, [ "info", "User '$username' ${cmd}ed." ];
+    }
+
+    return 1;
+}
+
+sub getemail
+{
+    my ($dbh, $remote, $args, $out) = @_;
+
+    unless (scalar(@$args) == 2) {
+        push @$out, [ "error", "This command takes exactly 1 argument.  Consult the reference." ];
+        return 0;
+    }
+    
+    my ($user) = ($args->[1]);
+    my $userid = &LJ::get_userid($user);
+
+    unless ($remote->{'priv'}->{'suspend'}) {
+        push @$out, [ "error", "You don't have access to see email addresses." ];
+        return 0;
+    }
+
+    unless ($userid) {
+        push @$out, [ "error", "Invalid user \"$user\"" ];
+        return 0;
+    }
+    
+    my $sth = $dbh->prepare("SELECT email, status FROM user WHERE userid=$userid");
+    $sth->execute;
+    my ($email, $status) = $sth->fetchrow_array;
+    
+    push @$out, [ "info", "User: $user" ];
+    push @$out, [ "info", "Email: $email" ];
+    push @$out, [ "info", "Status: $status  (A=approved, N=new, T=transferring)" ];
+
+    return 1;
+}
+
+sub finduser
+{
+    my ($dbh, $remote, $args, $out) = @_;
+
+    unless ($remote->{'priv'}->{'finduser'}) {
+        push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
+        return 0;
+    }
+
+    my ($crit, $data);
+    if (scalar(@$args) == 2) {
+        # new form; we can auto-detect emails easy enough
+        $data = $args->[1];
+        if ($data =~ /@/) {
+            $crit = 'email';
+        } else {
+            # TODO: autodetect ip and userid...
+            $crit = 'user';
+        }
+    } else {
+        # old format...but new variation
+        $crit = $args->[1];
+        $data = $args->[2];
+
+        # if they gave us a username and want to search by email, instead find
+        # all users with that email address
+        if ($crit eq 'email' && $data !~ /@/) {
+            my $u = LJ::load_user($data);
+            unless ($u) {
+                push @$out, [ "error", "User doesn't exist." ];
+                return 0;
+            }
+
+            $data = $u->{email};
+        }
+    }
+
+    my $qd = $dbh->quote($data);
+
+    my $userids;
+    my $ip;
+
+    if ($crit eq "email") {
+        $userids = $dbh->selectcol_arrayref("SELECT userid FROM user WHERE email=$qd");
+    } elsif ($crit eq "userid") {
+        $userids = $dbh->selectcol_arrayref("SELECT userid FROM user WHERE userid=$qd");
+    } elsif ($crit eq "user") {
+        $userids = $dbh->selectcol_arrayref("SELECT userid FROM user WHERE user=$qd");
+    } elsif ($crit eq "ip") {
+        $userids = $dbh->selectcol_arrayref("SELECT userid FROM userlog WHERE action='account_create' AND ip=$qd");
+        $ip = $data;
+    } elsif ($crit eq "sameip") {
+        $userids = $dbh->selectcol_arrayref("SELECT userid FROM user WHERE user=$qd");
+        #like 'user'+'ip'  #continue...
+    }
+
+
+    if ($dbh->err) {
+        push @$out, [ "error", "Error in database query: " . $dbh->errstr ];
+        return 0;
+    }
+    unless ($userids && @$userids) {
+        push @$out, [ "error", "No matches." ];
+        return 0;
+    }
+
+
+    if ($crit eq "sameip") { #continue...
+        my $res = $dbh->selectcol_arrayref("SELECT ip FROM userlog WHERE action='account_create' AND userid=$userids->[0]");
+        $ip = $res->[0];
+	$qd = $dbh->quote($ip);
+	$userids = $dbh->selectcol_arrayref("SELECT userid FROM userlog WHERE action='account_create' AND ip=$qd");
+    }
+
+
+    my $us = LJ::load_userids(@$userids);
+    foreach my $u (sort { $a->{userid} <=> $b->{userid} } values %$us) {
+
+	unless ($ip) {
+	   my $res = $dbh->selectcol_arrayref("SELECT ip FROM userlog WHERE action='account_create' AND userid=$u->{'userid'}");
+	   $ip = $res->[0];
+	}
+
+        push @$out, [ "info", "User: $u->{'user'} ".
+                      "($u->{'userid'}), journaltype: $u->{'journaltype'}, statusvis: $u->{'statusvis'}, $ip, email: ($u->{'status'}) $u->{'email'}" ];
+
+        if ($u->underage) {
+            my $reason;
+            if ($u->underage_status eq 'M') {
+                $reason = "manual set (see statushistory type set_underage)";
+            } elsif ($u->underage_status eq 'Y') {
+                $reason = "provided birthdate";
+            } elsif ($u->underage_status eq 'O') {
+                $reason = "unique cookie";
+            }
+            push @$out, [ "info", "  User is marked underage due to $reason." ];
+        }
+
+# no Paid accouns in LJR!
+#        foreach (LJ::run_hooks("finduser_extrainfo", { 'dbh' => $dbh, 'u' => $u })) {
+#            next unless $_->[0];
+#            foreach (split(/\n/, $_->[0])) {
+#                push @$out, [ "info", $_ ];
+#            }
+#        }
+    }
+    
+    return 1;
+}
+
+sub get_maintainer
+{
+    my ($dbh, $remote, $args, $out, $edge) = @_;
+    $edge ||= 'A';
+
+    unless (scalar(@$args) == 2) {
+        push @$out, [ "error", "This command takes exactly 1 argument.  Consult the reference." ];
+        return 0;
+    }
+    
+    unless ($remote->{'priv'}->{'finduser'}) {
+        push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
+        return 0;
+    }
+
+    my $user = $args->[1];
+    my $u = LJ::load_user($user);
+
+    unless ($u) {
+        push @$out, [ "error", "Invalid user \"$user\"" ];
+        return 0;
+    }
+
+    # journaltype eq 'P' means we're calling get_maintainer on a
+    # plain user and we should get a list of what they maintain instead of
+    # getting a list of what maintains them
+    my $ids = $u->{journaltype} eq 'P' ?
+              LJ::load_rel_target($u->{userid}, $edge) :
+              LJ::load_rel_user($u->{userid}, $edge);
+    $ids ||= [];
+
+    # finduser loop
+    finduser($dbh, $remote, ['finduser', 'userid', $_], $out) foreach @$ids;
+
+    return 1;
+}
+
+sub get_moderator
+{
+    # simple pass through, but specify to use the 'M' edge
+    return get_maintainer(@_, 'M');
+}
+
+sub infohistory
+{
+    my ($dbh, $remote, $args, $out) = @_;
+
+    unless ($remote->{'privarg'}->{'finduser'}->{'infohistory'}) {
+        push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
+        return 0;
+    }
+
+    my $user = $args->[1];
+    my $userid = LJ::get_userid($user);
+
+    unless ($userid) {
+        push @$out, [ "error", "Invalid user $user" ];
+        return 0;
+    }
+
+    my $sth = $dbh->prepare("SELECT * FROM infohistory WHERE userid='$userid'");
+    $sth->execute;
+    if (! $sth->rows) {
+        push @$out, [ "error", "Not much info found" ];
+	my $sth1 = $dbh->prepare("select FROM_UNIXTIME(logtime) as logtime, ip from userlog where userid=? and action='account_create'");
+	$sth1->execute($userid);
+	my $acc = $sth1->fetchrow_hashref;
+	push @$out, [ "info", "Account created at $acc->{'logtime'} from $acc->{'ip'} "];
+    } else {
+        push @$out, ["info", "Infohistory of user: $user"];
+	my $sth1 = $dbh->prepare("select FROM_UNIXTIME(logtime) as logtime, ip from userlog where userid=? and action='account_create'");
+	$sth1->execute($userid);
+	if ($sth1->rows) {
+	    my $acc = $sth1->fetchrow_hashref;
+	    push @$out, [ "info", "Account created at $acc->{'logtime'} from $acc->{'ip'} "];
+	}
+	else {
+	    push @$out, [ "error", "No account creation info found!" ];
+	}
+	
+        while (my $info = $sth->fetchrow_hashref) {        
+            $info->{'oldvalue'} ||= '(none)';
+            push @$out, [ "info", 
+                          "Changed $info->{'what'} at $info->{'timechange'}.\n".
+                          "Old value of $info->{'what'} was $info->{'oldvalue'}.".
+                          ($info->{'other'} ? 
+                           "\nOther information recorded: $info->{'other'}" : "") ];
+        }
+    }
+    return 1;
+}
+
+1;
+

local/cgi-bin/directorylib.pl

@@ -0,0 +1,650 @@
+#!/usr/bin/perl
+#
+# Directory search code.
+#
+############################################################
+#
+# Misc Notes...
+#
+# directory handle can only touch:
+#   community
+#   friends
+#   payments
+#   userinterests
+#   userprop
+#   userusage
+#
+
+use strict;
+package LJ::Dir;
+use Digest::MD5 qw(md5_hex);
+
+my $MAX_RETURN_RESULT = 1000;
+
+my %filters = (
+            'int' => { 'searcher' => \&search_int,
+                       'validate' => \&validate_int, },
+            'fr' => { 'searcher' => \&search_fr,
+                      'validate' => \&validate_fr, },
+            'fro' => { 'searcher' => \&search_fro,
+                      'validate' => \&validate_fro, },
+            'loc' => { 'validate' => \&validate_loc,
+                       'searcher' => \&search_loc, },
+            #'gen' => { 'validate' => \&validate_gen,
+            #           'searcher' => \&search_gen, },
+            'age' => { 'validate' => \&validate_age,
+                       'searcher' => \&search_age, },
+            'ut' => { 'validate' => \&validate_ut,
+                      'searcher' => \&search_ut, },
+            'com' => { 'searcher' => \&search_com,
+                       'validate' => \&validate_com, },
+            );
+
+# validate all filter options
+#
+sub validate
+{
+    my ($req, $errors) = @_;
+    my @filters;
+    foreach my $f (sort keys %filters) {
+        next unless $filters{$f}->{'validate'};
+        if ($filters{$f}->{'validate'}->($req, $errors)) {
+            push @filters, $f;
+        }
+    }
+    return sort @filters;
+}
+
+# entry point to do a search: give it
+#    a db-read handle
+#    directory master (must be able to write to dirsearchres2)
+#    hashref of the request,
+#    a listref of where to put the user hashrefs returned,
+#    hashref of where to return results of the query
+sub do_search
+{
+    my ($dbr, $dbdir, $req, $users, $info) = @_;
+    my $sth;
+
+    # clear return buffers
+    @{$users} = ();
+    %{$info} = ();
+
+    my @crits;
+    foreach my $f (sort keys %filters)
+    {
+        next unless $filters{$f}->{'validate'}->($req, []);
+
+        my @criteria = $filters{$f}->{'searcher'}->($dbr, $req, $info);
+        if (@criteria) {
+            push @crits, @criteria;
+        } else {
+            # filters return nothing to signal an error, and should have set $info->{'errmsg'}
+            $info->{'errmsg'} = "[Filter $f failed] $info->{'errmsg'}";
+            return 0;
+        }
+    }
+
+    unless (scalar(@crits)) {
+        $info->{'errmsg'} = "You did not enter any search criteria.";
+        return 0;
+    }
+
+    ########## time to build us some huge SQL statement.  yee haw.
+
+    my $orderby;
+    my %only_one_copy = qw(community c user u userusage uu);
+
+    ## keep track of what table aliases we've used
+    my %alias_used;
+    $alias_used{'u'} = "?";     # only used by dbr, not dbdir
+    $alias_used{'c'} = "?";     # might be used later, if opt_format eq "com"
+    $alias_used{'uu'} = "?";    # might be used later, if opt_sort is by time
+
+    my %conds;      # where condition -> 1
+    my %useridcol;  # all keys here equal each other (up.userid == uu.userid == ..)
+
+    ## foreach each critera, build up the query
+    foreach my $crit (@crits)
+    {
+        ### each search criteria has its own table aliases.  make those unique.
+        my %map_alias = ();  # keep track of local -> global table alias mapping
+
+        foreach my $localalias (keys %{$crit->{'tables'}})
+        {
+            my $table = $crit->{'tables'}->{$localalias};
+            my $newalias;
+
+            # some tables might be used multiple times but they're
+            # setup such that opening them multiple times is useless.
+            if ($only_one_copy{$table}) {
+                $newalias = $only_one_copy{$table};
+                $alias_used{$newalias} = $table;
+            } else {
+                my $ct = 1;
+                $newalias = $localalias;
+                while ($alias_used{$newalias}) {
+                    $ct++;
+                    $newalias = "$localalias$ct";
+                }
+                $alias_used{$newalias} = $table;
+            }
+
+            $map_alias{$localalias} = $newalias;
+        }
+
+        ## add each condition to the where clause, after fixing up aliases
+        foreach my $cond (@{$crit->{'conds'}}) {
+            $cond =~ s/\{(\w+?)\}/$map_alias{$1}/g;
+            $conds{$cond} = 1;
+        }
+
+        ## add join to u.userid table
+        my $cond = $crit->{'userid'};
+        if ($cond) {
+            $cond =~ s/\{(\w+?)\}/$map_alias{$1}/g;
+            $useridcol{$cond} = 1;
+        }
+    }
+
+    my $pagesize = $req->{'opt_pagesize'}+0 || 100;
+    if ($pagesize > 200) { $pagesize = 200; }
+    if ($pagesize < 5) { $pagesize = 5; }
+
+    $req->{'opt_format'} ||= "pics";
+    if ($req->{'opt_format'} eq "com") {
+        $alias_used{'c'} = "community";
+        $useridcol{"c.userid"} = 1;
+    }
+
+    $req->{'opt_sort'} ||= "ut";
+    if ($req->{'opt_sort'} eq "ut") {
+        $alias_used{'uu'} = 'userusage';
+        $useridcol{"uu.userid"} = 1;
+        $orderby = "ORDER BY uu.timeupdate DESC";
+    } elsif ($req->{'opt_sort'} eq "user") {
+        $alias_used{'u'} = 'user';
+        $useridcol{"u.userid"} = 1;
+        $orderby = "ORDER BY u.user";
+    } elsif ($req->{'opt_sort'} eq "name") {
+        $alias_used{'u'} = 'user';
+        $useridcol{"u.userid"} = 1;
+        $orderby = "ORDER BY u.name";
+    }
+
+    # delete reserved table aliases the didn't end up being used
+    foreach (keys %alias_used) {
+        delete $alias_used{$_} if $alias_used{$_} eq "?";
+    }
+
+    # add clauses to make all userid cols equal each other
+    my $useridcol;  # any one
+    foreach my $ca (keys %useridcol) {
+        foreach my $cb (keys %useridcol) {
+            next if $ca eq $cb;
+            $conds{"$ca=$cb"} = 1;
+        }
+        $useridcol = $ca;
+    }
+
+    my $fromwhat = join(", ", map { "$alias_used{$_} $_" } keys %alias_used);
+    my $conds = join(" AND ", keys %conds);
+
+    my $sql = "SELECT $useridcol FROM $fromwhat WHERE $conds $orderby LIMIT $MAX_RETURN_RESULT";
+
+    if ($req->{'sql'}) {
+        $info->{'errmsg'} = "SQL: $sql";
+        return 0;
+    }
+
+    my $qdig = $dbr->quote(md5_hex($sql));
+    my $hit_cache = 0;
+    my $count = 0;
+    my @ids;
+
+    # delete any stale results
+    $dbdir->do("DELETE FROM dirsearchres2 WHERE qdigest=$qdig AND ".
+               "dateins < DATE_SUB(NOW(), INTERVAL 15 MINUTE)");
+    # mark query as in progress.
+    $dbdir->do("INSERT INTO dirsearchres2 (qdigest, dateins, userids) ".
+               "VALUES ($qdig, NOW(), '[searching]')");
+    if ($dbdir->err)
+    {
+        # if there's an error inserting that, we know something's there.
+        # let's see what!
+        my $ids = $dbdir->selectrow_array("SELECT userids FROM dirsearchres2 ".
+                                          "WHERE qdigest=$qdig");
+        if (defined $ids) {
+            if ($ids eq "[searching]") {
+                # somebody else (or same user before) is still searching
+                $info->{'searching'} = 1;
+                return 1;
+            }
+            @ids = split(/,/, $ids);
+            $count = scalar(@ids);
+            $hit_cache = 1;
+        }
+    }
+
+    ## guess we'll have to query it.
+    if (! $hit_cache)
+    {
+        BML::do_later(sub {
+            $sth = $dbdir->prepare($sql);
+            $sth->execute;
+            while (my ($id) = $sth->fetchrow_array) {
+                push @ids, $id;
+            }
+            my $ids = $dbdir->quote(join(",", @ids));
+            $dbdir->do("REPLACE INTO dirsearchres2 (qdigest, dateins, userids) ".
+                       "VALUES ($qdig, NOW(), $ids)");
+        });
+        $info->{'searching'} = 1;
+        return 1;
+    }
+
+    my $page = $req->{'page'} || 1;
+    my $skip = ($page-1)*$pagesize;
+    my $pages = int($count / $pagesize) + (($count % $pagesize) ? 1 : 0);
+    $pages ||= 1;
+    if ($page > $pages) { $page = $pages; }
+    $info->{'pages'} = $pages;
+    $info->{'page'} = $page;
+    $info->{'first'} = ($page-1)*$pagesize+1;
+    $info->{'last'} = $page * $pagesize;
+    $info->{'count'} = $count;
+    if ($count == $MAX_RETURN_RESULT) {
+        $info->{'overflow'} = 1;
+    }
+    if ($page == $pages) { $info->{'last'} = $count; }
+
+    ## now, get info on the ones we want.
+    @ids = grep{ $_+0 } @ids[($info->{'first'}-1)..($info->{'last'}-1)];
+    return 1 unless @ids;
+
+    my %u;
+    LJ::load_userids_multiple([ map { $_ => \$u{$_} } @ids ]);
+    my $tu = LJ::get_timeupdate_multi_fast(undef, \%u);  # %u = hint
+    my $now = time();
+
+    # need to get community info
+    if ($req->{'opt_format'} eq "com") {
+        my $in = join(',', @ids);
+        my $sth = $dbr->prepare("SELECT userid, membership, postlevel ".
+                                "FROM community ".
+                                "WHERE userid IN ($in)");
+        $sth->execute;
+        while (my ($uid, $mem, $postlev) = $sth->fetchrow_array) {
+            next unless $u{$uid};
+            next unless $u{$uid}->{'statusvis'} eq "V";
+            $u{$uid}->{'membership'} = $mem;
+            $u{$uid}->{'postlevel'} = $postlev;
+        }
+        foreach (@ids) {
+            delete $u{$_} unless $u{$_}->{'membership'};
+        }
+    }
+
+    foreach my $id (@ids) {
+        next unless $u{$id};
+        $u{$id}->{'secondsold'} = $tu->{$id} ? $now - $tu->{$id} : undef;
+        push @$users, $u{$id} if $u{$id};
+    }
+
+    return 1;
+}
+
+sub ago_text
+{
+    my $secondsold = shift;
+    return "Never." unless ($secondsold);
+    my $num;
+    my $unit;
+    if ($secondsold > 60*60*24*7) {
+        $num = int($secondsold / (60*60*24*7));
+        $unit = "week";
+    } elsif ($secondsold > 60*60*24) {
+        $num = int($secondsold / (60*60*24));
+        $unit = "day";
+    } elsif ($secondsold > 60*60) {
+        $num = int($secondsold / (60*60));
+        $unit = "hour";
+    } elsif ($secondsold > 60) {
+        $num = int($secondsold / (60));
+        $unit = "minute";
+    } else {
+        $num = $secondsold;
+        $unit = "second";
+    }
+    return "$num $unit" . ($num==1?"":"s") . " ago";
+}
+
+########## INTEREST ############
+
+sub validate_int
+{
+    my ($req, $errors) = @_;
+
+    my $int = lc($req->{'int_like'});
+    $int =~ s/^\s+//;
+    $int =~ s/\s+$//;
+    return 0 unless $int;
+
+    $req->{'int_like'} = $int;
+    return 1;
+}
+
+sub search_int
+{
+    my ($dbr, $req, $info) = @_;
+    my $arg = $req->{'int_like'};
+    push @{$info->{'english'}}, "are interested in \"$arg\"";
+
+    ## find interest id, if one doth exist.
+    my $qint = $dbr->quote($req->{'int_like'});
+    my $intid = $dbr->selectrow_array("SELECT intid FROM interests ".
+                                      "WHERE interest=$qint");
+    unless ($intid) {
+        $info->{'errmsg'} = "The interest you have entered is not valid.";
+        return;
+    }
+
+    my $UI_TABLE = $req->{'com_do'} ? "comminterests" : "userinterests";
+
+    return {
+        'tables' => {
+            'ui' => $UI_TABLE,
+        },
+        'conds' => [ "{ui}.intid=$intid" ],
+        'userid' => "{ui}.userid",
+    };
+}
+
+######## HAS FRIEND ##############
+
+sub validate_fr
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'fr_user'} =~ /\S/;
+    return 1;
+}
+
+sub search_fr
+{
+    my ($dbr, $req, $info) = @_;
+
+    my $user = lc($req->{'fr_user'});
+    my $arg = $user;
+
+    push @{$info->{'english'}}, "consider \"$arg\" a friend";
+
+    my $friendid = LJ::get_userid($user);
+
+    return {
+        'tables' => {
+            'f' => 'friends',
+        },
+        'conds' => [ "{f}.friendid=$friendid" ],
+        'userid' => "{f}.userid",
+    };
+}
+
+
+######## FRIEND OF ##############
+
+sub validate_fro
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'fro_user'} =~ /\S/;
+    return 1;
+}
+
+sub search_fro
+{
+    my ($dbr, $req, $info) = @_;
+
+    my $user = lc($req->{'fro_user'});
+    my $arg = $user;
+
+    push @{$info->{'english'}}, "are considered a friend by \"$arg\"";
+
+    my $userid = LJ::get_userid($user);
+
+    return {
+        'tables' => {
+            'f' => 'friends',
+        },
+        'conds' => [ "{f}.userid=$userid" ],
+        'userid' => "{f}.friendid",
+    };
+}
+
+
+########### LOCATION ###############
+
+sub validate_loc
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'loc_cn'};
+
+    unless ($req->{'loc_cn'} =~ /^[A-Z0-9]{2}$/ ||  # ISO code
+            $req->{'loc_cn'} =~ /^LJ/)           # site-local country/region code
+    {
+        push @$errors, "Invalid country for location search.";
+        return 0;
+    }
+    return 1;
+}
+
+sub search_loc
+{
+    my ($dbr, $req, $info) = @_;
+    my ($sth);
+
+    my ($longcountry, $longstate, $longcity);
+    my $qcode = $dbr->quote(uc($req->{'loc_cn'}));
+    $sth = $dbr->prepare("SELECT item FROM codes WHERE type='country' AND code=$qcode");
+    $sth->execute;
+    ($longcountry) = $sth->fetchrow_array;
+
+    $longstate = lc($req->{'loc_st'});
+    $longstate =~ s/(\w+)/\u$1/g;
+    $longcity = lc($req->{'loc_ci'});
+    $longcity =~ s/(\w+)/\u$1/g;
+
+    $req->{'loc_st'} = lc($req->{'loc_st'});
+    $req->{'loc_ci'} = lc($req->{'loc_ci'});
+    
+    if ($req->{'loc_cn'} eq "US") {
+        my $qstate = $dbr->quote($req->{'loc_st'});
+        if (length($req->{'loc_st'}) > 2) {
+            ## convert long state name into state code
+            $sth = $dbr->prepare("SELECT code FROM codes WHERE type='state' AND item=$qstate");
+            $sth->execute;
+            my ($code) = $sth->fetchrow_array;
+            if ($code) {
+                $req->{'loc_st'} = lc($code);
+            }
+        } else {
+            $sth = $dbr->prepare("SELECT item FROM codes WHERE type='state' AND code=$qstate");
+            $sth->execute;
+            ($longstate) = $sth->fetchrow_array;
+        }
+    }
+
+    push @{$info->{'english'}}, "live in " . join(", ", grep { $_; } ($longcity, $longstate, $longcountry));
+
+    my $p = LJ::get_prop("user", "sidx_loc");
+    unless ($p) {
+        $info->{'errmsg'} = "Userprop sidx_loc doesn't exist. Run update-db.pl?";
+        return;
+    }
+
+    my $prefix = join("-", $req->{'loc_cn'}, $req->{'loc_st'}, $req->{'loc_ci'});
+    $prefix =~ s/\-+$//;  # remove trailing hyphens
+    $prefix =~ s![\_\%\"\']!\\$&!g;
+                                                                  
+    #### do the sub requests.
+
+    return {
+        'tables' => {
+            'up' => 'userprop', 
+        }, 
+        'conds' => [ "{up}.upropid=$p->{'id'}",
+                     "{up}.value LIKE '$prefix%'",
+                     ],
+        'userid' => "{up}.userid",
+    };
+
+}
+
+########### GENDER ###################
+
+sub validate_gen
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'gen_sel'};
+    unless ($req->{'gen_sel'} eq "M" ||
+            $req->{'gen_sel'} eq "F")
+    {
+        push @$errors, "You must select either Male or Female when searching by gender.\n";
+        return 0;
+    }
+    return 1;
+}
+
+sub search_gen
+{
+    my ($dbr, $req, $info) = @_;
+    my $args = $req->{'gen_sel'};
+
+    push @{$info->{'english'}}, "are " . ($args eq "M" ? "male" : "female");
+    my $qgen = $dbr->quote($args);
+
+    my $p = LJ::get_prop("user", "gender");
+    unless ($p) {
+        $info->{'errmsg'} = "Userprop gender doesn't exist. Run update-db.pl?";
+        return;
+    }
+
+    return {
+        'tables' => {
+            'up' => 'userprop',
+        },
+        'conds' => [ "{up}.upropid=$p->{'id'}",
+                     "{up}.value=$qgen",
+                     ],
+        'userid' => "{up}.userid",
+    };
+}
+
+########### AGE ###################
+
+sub validate_age
+{
+    my ($req, $errors) = @_;
+    return 0 if $req->{'age_min'} eq "" && $req->{'age_max'} eq "";
+
+    for (qw(age_min age_max)) {
+        unless ($req->{$_} =~ /^\d+$/) {
+            push @$errors, "Both min and max age must be specified for an age query.";
+            return 0;
+        }
+    }
+    if ($req->{'age_min'} > $req->{'age_max'}) {
+        push @$errors, "Minimum age must be less than maximum age.";
+        return 0;
+    }
+    if ($req->{'age_min'} < 14) {
+        push @$errors, "You cannot search for users under 14 years of age.";
+        return 0;
+    }
+    return 1;
+}
+
+sub search_age
+{
+    my ($dbr, $req, $info) = @_;
+    my $qagemin = $dbr->quote($req->{'age_min'});
+    my $qagemax = $dbr->quote($req->{'age_max'});
+    my $args = "$req->{'age_min'}-$req->{'age_max'}";
+
+    if ($req->{'age_min'} == $req->{'age_max'}) {
+        push @{$info->{'english'}}, "are $req->{'age_min'} years old";
+    } else {
+        push @{$info->{'english'}}, "are between $req->{'age_min'} and $req->{'age_max'} years old";
+    }
+
+    my $p = LJ::get_prop("user", "sidx_bdate");
+    unless ($p) {
+        $info->{'errmsg'} = "Userprop sidx_bdate doesn't exist. Run update-db.pl?";
+        return;
+    }
+
+    return {
+        'tables' => {
+            'up' => 'userprop',
+        },
+        'conds' => [ "{up}.upropid=$p->{'id'}",
+                     "{up}.value BETWEEN DATE_SUB(NOW(), INTERVAL $qagemax YEAR) AND DATE_SUB(NOW(), INTERVAL $qagemin YEAR)",
+                     ],
+        'userid' => "{up}.userid",
+    };
+}
+
+########### UPDATE TIME ###################
+
+sub validate_ut
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'ut_days'};
+    unless ($req->{'ut_days'} =~ /^\d+$/) {
+        push @$errors, "Days since last updated must be a postive, whole number.";
+        return;
+    }
+    return 1;
+}
+
+sub search_ut
+{
+    my ($dbr, $req, $info) = @_;
+    my $qdays = $req->{'ut_days'}+0;
+
+    if ($qdays == 1) {
+        push @{$info->{'english'}}, "have updated their journal in the past day";
+    } else {
+        push @{$info->{'english'}}, "have updated their journal in the past $qdays days";
+    }
+
+    return {
+        'tables' => {
+            'uu' => 'userusage',
+        },
+        'conds' => [ "{uu}.timeupdate > DATE_SUB(NOW(), INTERVAL $qdays DAY)", ],
+        'userid' => "{uu}.userid",
+    };
+}
+
+######### community
+
+sub validate_com
+{
+    my ($req, $errors) = @_;
+    return 0 unless $req->{'com_do'};
+    return 1;
+}
+
+sub search_com
+{
+    my ($dbr, $req, $info) = @_;
+    $info->{'allwhat'} = "communities";
+
+    return {
+        'tables' => {
+            'c' => 'community',
+        },
+        'userid' => "{c}.userid",
+    };
+}
+
+1;

local/cgi-bin/emailcheck.pl

@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+#
+# Function to reject bogus email addresses
+#
+
+package LJ;
+
+sub check_email 
+{
+    my ($email, $errors) = @_;
+
+    # Trim off whitespace and force to lowercase.
+    $email =~ s/^\s+//;
+    $email =~ s/\s+$//;
+    $email = lc $email;
+
+    my $reject = sub {
+        my $errcode = shift;
+        my $errmsg = shift;
+        # TODO: add $opts to end of check_email and make option 
+        #       to either return error codes, or let caller supply
+        #       a subref to resolve error codes into native language
+        #       error messages (probably via BML::ML hash, or something)
+        push @$errors, $errmsg; 
+        return;
+    };
+
+    # Empty email addresses are not good.
+    unless ($email) {
+        return $reject->("empty",
+                         "Your email address cannot be blank.");
+    }
+
+    # Check that the address is of the form username@some.domain.
+    my ($username, $domain);
+    if ($email =~ /^([^@]+)@([^@]+)/) {
+        $username = $1;
+        $domain = $2;
+    } else {
+        return $reject->("bad_form",
+                         "You did not give a valid email address.  An email address looks like username\@some.domain");
+    }
+
+    # Check the username for invalid characters.
+    unless ($username =~ /^[^\s\",;\(\)\[\]\{\}\<\>]+$/) {
+        return $reject->("bad_username",
+                         "You have invalid characters in your email address username.");
+    }
+
+    # Check the domain name.
+    unless ($domain =~ /^[\w-]+(\.[\w-]+)*\.(ac|ad|ae|aero|af|ag|ai|al|am|an|ao|aq|ar|arpa|as|at|au|aw|az|ba|bb|bd|be|bf|bg|bh|bi|biz|bj|bm|bn|bo|br|bs|bt|bv|bw|by|bz|ca|cc|cd|cf|cg|ch|ci|ck|cl|cm|cn|co|com|coop|cr|cu|cv|cx|cy|cz|de|dj|dk|dm|do|dz|ec|edu|ee|eg|er|es|et|fi|fj|fk|fm|fo|fr|ga|gb|gd|ge|gf|gg|gh|gi|gl|gm|gn|gov|gp|gq|gr|gs|gt|gu|gw|gy|hk|hm|hn|hr|ht|hu|id|ie|il|im|in|info|int|io|iq|ir|is|it|je|jm|jo|jp|ke|kg|kh|ki|km|kn|kr|kw|ky|kz|la|lb|lc|li|lk|lr|ls|lt|lu|lv|ly|ma|mc|md|mg|mh|mil|mk|ml|mm|mn|mo|mp|mq|mr|ms|mt|mu|museum|mv|mw|mx|my|mz|na|name|nc|ne|net|nf|ng|ni|nl|no|np|nr|nu|nz|om|org|pa|pe|pf|pg|ph|pk|pl|pm|pn|pr|pro|ps|pt|pw|py|qa|re|ro|ru|rw|sa|sb|sc|sd|se|sg|sh|si|sj|sk|sl|sm|sn|so|sr|st|su|sv|sy|sz|tc|td|tf|tg|th|tj|tk|tm|tn|to|tp|tr|tt|tv|tw|tz|ua|ug|uk|um|us|uy|uz|va|vc|ve|vg|vi|vn|vu|wf|ws|ye|yt|yu|za|zm|zw)$/)
+    {
+        return $reject->("bad_domain",
+                         "Your email address domain is invalid.");
+    }
+
+    if ($domain =~ /spam/) # to avoid spam.su and suchlike
+    { 
+	return $reject->("bad_domain",
+			 "Your email address domain is invalid.");
+    }
+
+
+
+    # Catch misspellings of hotmail.com
+    if ($domain =~ /^(otmail|hotmial|hotmil|hotamail|hotmaul|hoatmail|hatmail|htomail)\.(cm|co|com|cmo|om)$/ or
+        $domain =~ /^hotmail\.(cm|co|om|cmo)$/)
+    {
+        return $reject->("bad_hotmail_spelling",
+                         "You gave $email as your email address.  Are you sure you didn't mean hotmail.com?");
+    }
+
+    # Catch misspellings of aol.com
+    elsif ($domain =~ /^(ol|aoll)\.(cm|co|com|cmo|om)$/ or
+           $domain =~ /^aol\.(cm|co|om|cmo)$/)
+    {
+        return $reject->("bad_aol_spelling",
+                         "You gave $email as your email address.  Are you sure you didn't mean aol.com?");
+    }
+
+    # Catch web addresses (two or more w's followed by a dot)
+#    elsif ($username =~ /^www*\./)
+#    {
+#        return $reject->("web_address",
+#                         "You gave $email as your email address, but it looks more like a web address to me.");
+#    }
+}
+
+1;
+

local/cgi-bin/ljdefaults.pl

@@ -0,0 +1,241 @@
+#!/usr/bin/perl
+#
+# Do not edit this file.  You should edit ljconfig.pl, which you should have at
+# cgi-bin/ljconfig.pl.  If you don't, copy it from doc/ljconfig.pl.txt to cgi-bin
+# and edit it there.  This file only provides backup default values for upgrading.
+#
+
+{
+    package LJ;
+    use Sys::Hostname ();
+
+    $DEFAULT_STYLE ||= { 
+        'core' => 'core1',
+        'layout' => 'generator/layout',
+        'i18n' => 'generator/en',
+    };
+
+    # cluster 0 is no longer supported
+    $DEFAULT_CLUSTER ||= 1;
+    @CLUSTERS = (1) unless @CLUSTERS;
+
+    $HOME = $ENV{'LJHOME'};
+    $HTDOCS = "$HOME/htdocs";
+    $BIN = "$HOME/bin";
+
+    $SERVER_NAME ||= Sys::Hostname::hostname();
+    
+    $UNICODE = 1 unless defined $UNICODE;
+
+    @LANGS = ("en") unless @LANGS;
+    $DEFAULT_LANG ||= $LANGS[0];
+
+    $SITENAME ||= "NameNotConfigured.com";
+    unless ($SITENAMESHORT) {
+        $SITENAMESHORT = $SITENAME;
+        $SITENAMESHORT =~ s/\..*//;  # remove .net/.com/etc
+    }
+    $SITENAMEABBREV ||= "[??]";
+
+    $NODB_MSG ||= "Database temporarily unavailable.  Try again shortly.";
+    $MSG_READONLY_USER ||= "Database temporarily in read-only mode during maintenance.";
+
+    $SITEROOT ||= "http://www.$DOMAIN:8011";
+    $IMGPREFIX ||= "$SITEROOT/img";
+    $STATPREFIX ||= "$SITEROOT/stc";
+    $JSPREFIX ||= "$SITEROOT/js";
+    $USERPIC_ROOT ||= "$LJ::SITEROOT/userpic";
+    $PALIMGROOT ||= "$LJ::SITEROOT/palimg";
+
+    if ($LJ::DB_USERIDMAP ||= "") {
+        $LJ::DB_USERIDMAP .= "." unless  $LJ::DB_USERIDMAP =~ /\.$/;
+    }
+
+    # path to sendmail and any necessary options
+    $SENDMAIL ||= "/usr/sbin/sendmail -t -oi";
+
+    # protocol, mailserver hostname, and preferential weight.
+    # qmtp, smtp, dmtp, and sendmail are the currently supported protocols.
+    @MAIL_TRANSPORTS = ( [ 'sendmail', $SENDMAIL, 1 ] ) unless @MAIL_TRANSPORTS;
+
+    # where we set the cookies (note the period before the domain)
+    $COOKIE_DOMAIN ||= ".$DOMAIN";
+    $COOKIE_PATH   ||= "/";
+    @COOKIE_DOMAIN_RESET = ("", "$DOMAIN", ".$DOMAIN") unless @COOKIE_DOMAIN_RESET;
+
+    ## default portal options
+    @PORTAL_COLS = qw(main right moz) unless (@PORTAL_COLS);
+
+    $PORTAL_URI ||= "/portal/";           # either "/" or "/portal/"    
+
+    $PORTAL_LOGGED_IN ||= {'main' => [ 
+                                     [ 'update', 'mode=full'],
+                                     ],
+                         'right' => [ 
+                                      [ 'stats', '', ],
+                                      [ 'bdays', '', ],
+                                      [ 'popfaq', '', ],
+                                      ] };
+    $PORTAL_LOGGED_OUT ||= {'main' => [ 
+                                      [ 'update', 'mode='],
+                                      ],
+                          'right' => [ 
+                                       [ 'login', '', ],
+                                       [ 'stats', '', ],
+                                       [ 'randuser', '', ],
+                                       [ 'popfaq', '', ],
+                                       ],
+                          'moz' => [
+                                    [ 'login', '', ],
+                                    ],
+                          };
+
+    # this option can be a boolean or a URL, but internally we want a URL
+    # (which can also be a boolean)
+    if ($LJ::OPENID_SERVER && $LJ::OPENID_SERVER == 1) {
+        $LJ::OPENID_SERVER = "$LJ::SITEROOT/openid/server.bml";
+    }
+
+    # set default capability limits if the site maintainer hasn't.
+    {
+        my %defcap = (
+                      'checkfriends' => 1,
+                      'checkfriends_interval' => 60,
+                      'friendsviewupdate' => 30,
+                      'makepoll' => 1,
+                      'maxfriends' => 500,
+                      'moodthemecreate' => 1,
+                      'styles' => 1,
+                      's2styles' => 1,
+                      's2viewentry' => 1,
+                      's2viewreply' => 1,
+                      's2stylesmax' => 10,
+                      's2layersmax' => 50,
+                      'textmessage' => 1,
+                      'todomax' => 100,
+                      'todosec' => 1,
+                      'userdomain' => 0,
+                      'useremail' => 0,
+                      'userpics' => 5,
+                      'findsim' => 1,
+                      'full_rss' => 1,
+                      'can_post' => 1,
+                      'get_comments' => 1,
+                      'leave_comments' => 1,
+                      'mod_queue' => 50,
+                      'mod_queue_per_poster' => 1,
+                      'weblogscom' => 0,
+                      'hide_email_after' => 0,
+                      'userlinks' => 5,
+                      'maxcomments' => $MAXCOMMENTS || 5000,
+                      'rateperiod-lostinfo' => 24*60, # 24 hours
+                      'rateallowed-lostinfo' => 5,
+                      'tools_recent_comments_display' => 110,
+                      );
+        foreach my $k (keys %defcap) {
+            next if (defined $LJ::CAP_DEF{$k});
+            $LJ::CAP_DEF{$k} = $defcap{$k};	    
+        }
+    }
+
+    # FIXME: should forcibly limit userlinks to 255 (tinyint)
+
+    # set default userprop limits if site maintainer hasn't
+    {
+        my %defuser = (
+                       's1_lastn_style'    => 29,
+                       's1_friends_style'  => 20,
+                       's1_calendar_style' => 2,
+                       's1_day_style'      => 11,
+                       );
+        foreach my $k (keys %defuser) {
+            next if (defined $LJ::USERPROP_DEF{$k});
+            $LJ::USERPROP_DEF{$k} = $defuser{$k};
+        }
+    }
+
+    # Send community invites from the admin address unless otherwise specified
+    $COMMUNITY_EMAIL ||= $ADMIN_EMAIL;
+
+    # By default, auto-detect account types for
+    # <lj user> tags only if using memcache
+    unless (defined $LJ::DYNAMIC_LJUSER) {
+        $LJ::DYNAMIC_LJUSER = scalar(@LJ::MEMCACHE_SERVERS) ? 1 : 0;
+    }
+
+    # The list of content types that we consider valid for gzip compression.
+    %GZIP_OKAY = (
+        'text/html' => 1,               # regular web pages; XHTML 1.0 "may" be this
+        'text/xml' => 1,                # regular XML files
+        'application/xml' => 1,         # XHTML 1.1 "may" be this
+        'application/xhtml+xml' => 1,   # XHTML 1.1 "should" be this
+        'application/rdf+xml' => 1,     # FOAF should be this
+    ) unless %GZIP_OKAY;
+
+    # maximum FOAF friends to return (so the server doesn't get overloaded)
+    $MAX_FOAF_FRIENDS ||= 1000;
+
+    # maximum number of friendofs to load/memcache (affects userinfo.bml display)
+    $MAX_FRIENDOF_LOAD ||= 5000;
+
+    # whether to proactively delete any comments associated with an entry when we assign
+    # a new jitemid (see the big comment above LJ::Protocol::new_entry_cleanup_hack)
+    $NEW_ENTRY_CLEANUP_HACK ||= 0;
+
+    # block size is used in stats generation code that gets n rows from the db at a time
+    $STATS_BLOCK_SIZE ||= 10_000;
+
+    # Maximum number of comments to display on Recent Comments page
+    $TOOLS_RECENT_COMMENTS_MAX ||= 110;
+
+    # setup the mogilefs defaults so we can create the necessary domains
+    # and such. it is not recommended that you change the name of the
+    # classes. you can feel free to add your own or alter the mindevcount
+    # from within ljconfig.pl, but the LiveJournal code uses these class
+    # names elsewhere and depends on them existing if you're using MogileFS
+    # for storage.
+    #
+    # also note that this won't actually do anything unless you have
+    # defined a MOGILEFS_CONFIG hash in ljconfig.pl and you explicitly set
+    # at least the hosts key to be an arrayref of ip:port combinations
+    # indicating where to reach your local MogileFS server.
+    %MOGILEFS_CONFIG = () unless scalar(%MOGILEFS_CONFIG);
+    $MOGILEFS_CONFIG{domain}                 ||= 'livejournal';
+    $MOGILEFS_CONFIG{classes}                ||= {};
+    $MOGILEFS_CONFIG{classes}->{userpics}    ||= 3;
+    $MOGILEFS_CONFIG{classes}->{captcha}     ||= 2;
+
+    # Default to allow all reproxying.
+    %REPROXY_DISABLE = () unless %REPROXY_DISABLE;
+
+    # Default error message for age verification needed
+    $UNDERAGE_ERROR ||= "Sorry, your account needs to be <a href='$SITEROOT/agecheck/'>age verified</a> before you can leave any comments.";
+
+    # Terms of Service revision requirements
+    foreach (
+             [ rev   => '0.0' ],
+             [ title => 'Terms of Service agreement required' ],
+             [ html  => '' ],
+             [ text  => '' ]
+             )
+    {
+        $LJ::REQUIRED_TOS{$_->[0]} = $_->[1]
+            unless defined $LJ::REQUIRED_TOS{$_->[0]};
+    }
+
+    # setup default minimal style information
+    $MINIMAL_USERAGENT{$_} ||= 1 foreach qw(Links Lynx w BlackBerry); # w is for w3m
+    $MINIMAL_BML_SCHEME ||= 'lynx';
+    $MINIMAL_STYLE{'core'} ||= 'core1';
+
+    # maximum size to cache s2compiled data
+    $MAX_S2COMPILED_CACHE_SIZE ||= 7500; # bytes
+    $S2COMPILED_MIGRATION_DONE ||= 0;    # turn on after s2compiled2 migration
+
+}
+
+# no dependencies.
+# <LJDEP>
+# </LJDEP>
+
+return 1;

local/cgi-bin/ljfeed.pl

@@ -0,0 +1,567 @@
+#!/usr/bin/perl
+
+use strict;
+
+package LJ::Feed;
+
+eval "use LJR::Distributed;";
+my $ljr = $@ ? 0 : 1;
+
+if ($ljr) {
+  use LJR::Distributed;
+  require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
+}
+
+
+my %feedtypes = (
+    rss  => \&create_view_rss,
+    atom => \&create_view_atom,
+    foaf => \&create_view_foaf,
+);
+
+sub make_feed
+{
+    my ($r, $u, $remote, $opts) = @_;
+
+    $opts->{pathextra} =~ s!^/(\w+)!!;
+    my $feedtype = $1;
+    my $viewfunc = $feedtypes{$feedtype};
+
+    unless ($viewfunc) {
+        $opts->{'handler_return'} = 404;
+        return undef;
+    }
+    
+    $r->notes('codepath' => "feed.$feedtype") if $r;
+
+    if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
+        $opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) . "/data/$feedtype";
+        return undef;
+    }
+
+    my $userid = $u->{'userid'};
+
+    # try cached copy
+    # (ljprotocol.pl:  memcache "rss:$userid" deleted if "rsslastmod:$userid" changed)
+    my $lastmod = LJ::MemCache::get([$userid, "rsslastmod:$userid"]); # more strict than timeupdate: care of edit!
+
+    my $ims = $r->header_in('If-Modified-Since');
+    my $theirtime = LJ::http_to_time($ims) if $ims;
+
+    # If-Modified-Since, try #1
+    if (defined $lastmod && $ims && $feedtype ne 'foaf'  && $theirtime >= $lastmod) {
+        #$opts->{'handler_return'} = 304; #Not Modified
+        $opts->{'notmodified'} = 1;
+        return undef;
+    }
+
+    # text already in memcache -
+    if ($feedtype eq 'rss' && !$remote) {
+        my $data = LJ::MemCache::get([$userid, "rss:$userid"]); #{lastmod => $lastmod, text => $ret}
+        if ($data) {
+            if (!defined $lastmod) {
+                LJ::MemCache::set([$userid, "rsslastmod:$userid"], $data->{lastmod});
+            }
+            $opts->{'cachecontrol'} = 'max-age=600, private, proxy-revalidate';
+            $opts->{'contenttype'} = 'text/xml; charset='.$opts->{'saycharset'};
+            #$r->header_out("Last-Modified", LJ::time_to_http($data->{lastmod}));
+            $r->set_last_modified($data->{lastmod});
+            return $data->{text};
+        }
+    }
+
+    LJ::load_user_props($u, qw/ journaltitle journalsubtitle opt_synlevel /);
+
+    LJ::text_out(\$u->{$_}) 
+        foreach ("name", "url", "urlname");
+    
+    # opt_synlevel will default to 'full'
+    $u->{'opt_synlevel'} = 'full' 
+        unless $u->{'opt_synlevel'} =~ /^(?:full|summary|title)$/;
+
+    # some data used throughout the channel
+    my $journalinfo = {
+        u         => $u,
+        link      => LJ::journal_base($u) . "/",
+        title     => $u->{journaltitle} || $u->{name} || $u->{user},
+        subtitle  => $u->{journalsubtitle} || $u->{name},
+        builddate => LJ::time_to_http(time()),
+    };
+
+    # if we do not want items for this view, just call out
+    $opts->{noitems} = 1 if $feedtype eq 'foaf';
+
+    return $viewfunc->($journalinfo, $u, $opts)
+        if ($opts->{'noitems'});
+
+    # for syndicated accounts, redirect to the syndication URL
+    # However, we only want to do this if the data we're returning
+    # is similar. (Not FOAF, for example)
+
+    if ($u->{'journaltype'} eq 'Y') {
+        my $dbr = LJ::get_db_reader();
+        my $synurl = $dbr->selectrow_array("SELECT synurl FROM syndicated WHERE userid=$userid");
+        unless ($synurl) {
+            return 'No syndication URL available.';
+        }
+        $opts->{'redir'} = $synurl;
+        return undef;
+    }
+
+    ## load the items
+    my @items = LJ::get_recent_items({
+        'u' => $u,
+        'clustersource' => 'slave',
+        'remote' => $remote,
+        'itemshow' => 25,
+        'order' => "logtime",
+        'friendsview' => 1,           # this returns rlogtimes
+        'dateformat' => "S2",         # S2 format time format is easier
+    });
+
+    if (!defined $lastmod) {
+        $lastmod = @items ? $LJ::EndOfTime - $items[0]->{'rlogtime'} : 0;
+        LJ::MemCache::set([$userid, "rsslastmod:$userid"], $lastmod);
+
+        # If-Modified-Since, try #2
+        if ($ims && $theirtime >= $lastmod) {
+            #$opts->{'handler_return'} = 304; #Not Modified
+            $opts->{'notmodified'} = 1;
+            return undef;
+        }
+    }
+
+    # set last-modified header:
+    #$r->header_out("Last-Modified", LJ::time_to_http($lastmod));
+    $r->set_last_modified($lastmod); # including $lastmod = 0
+    $journalinfo->{'modtime'} = $lastmod;
+
+    #$opts->{'cachecontrol'} = 'max-age=600, proxy-revalidate'; # unless $remote; #hmm
+    $opts->{'cachecontrol'} = 'max-age=600, private, proxy-revalidate'; # if $remote;
+    $opts->{'contenttype'} = 'text/xml; charset='.$opts->{'saycharset'};
+
+
+    # email address of journal owner, but respect their privacy settings
+    if ($u->{'allow_contactshow'} eq "Y" && $u->{'opt_whatemailshow'} ne "N" && $u->{'opt_mangleemail'} ne "Y") {
+        my $cemail;
+        
+        # default to their actual email
+        $cemail = $u->{'email'};
+        
+        # use their livejournal email if they have one
+        if ($LJ::USER_EMAIL && $u->{'opt_whatemailshow'} eq "L" &&
+            LJ::get_cap($u, "useremail") && ! $u->{'no_mail_alias'}) {
+
+            $cemail = "$u->{'user'}\@$LJ::USER_DOMAIN";
+        } 
+
+        # clean it up since we know we have one now
+        $journalinfo->{email} = $cemail;
+    } else { $journalinfo->{email} = "$u->{'user'} at lj.rossia.org"; }
+
+    my %posteru = ();  # map posterids to u objects
+    LJ::load_userids_multiple([map { $_->{'posterid'}, \$posteru{$_->{'posterid'}} } @items], [$u]);
+
+    my @cleanitems;
+  ENTRY:
+    foreach my $it (@items) 
+    {
+        # load required data
+        my $itemid  = $it->{'itemid'};
+        my $ditemid = $itemid*256 + $it->{'anum'};
+
+        next ENTRY if $posteru{$it->{'posterid'}} && $posteru{$it->{'posterid'}}->{'statusvis'} eq 'S';
+
+        my $props = $it->{'props'};
+
+        # see if we have a subject and clean it
+        my $subject = $it->{'text'}->[0];
+        if ($subject) {
+            $subject =~ s/[\r\n]/ /g;
+            LJ::CleanHTML::clean_subject_all(\$subject);
+        }
+
+        # an HTML link to the entry. used if we truncate or summarize
+        my $readmore = "<b>(<a href=\"$journalinfo->{link}$ditemid.html\">Read more ...</a>)</b>";
+
+        # empty string so we don't waste time cleaning an entry that won't be used
+        my $event = $u->{'opt_synlevel'} eq 'title' ? '' : $it->{'text'}->[1];
+
+        # clean the event, if non-empty
+        my $ppid = 0;
+        if ($event) {
+
+            # users without 'full_rss' get their logtext bodies truncated
+            # do this now so that the html cleaner will hopefully fix html we break
+            unless (LJ::get_cap($u, 'full_rss')) {
+                my $trunc = LJ::text_trim($event, 0, 80);
+                $event = "$trunc $readmore" if $trunc ne $event;
+            }
+
+            LJ::CleanHTML::clean_event(\$event, {'ljcut_disable'=>1},
+                                       { 'preformatted' => $props->{'opt_preformatted'} });
+        
+            # do this after clean so we don't have to about know whether or not
+            # the event is preformatted
+            if ($u->{'opt_synlevel'} eq 'summary') {
+
+                # assume the first paragraph is terminated by two <br> or a </p>
+                # valid XML tags should be handled, even though it makes an uglier regex
+                if ($event =~ m!((<br\s*/?\>(</br\s*>)?\s*){2})|(</p\s*>)!i) {
+                    # everything before the matched tag + the tag itself
+                    # + a link to read more
+                    $event = $` . $& . $readmore;
+                }
+            }
+
+            LJ::Poll::replace_polls_with_links(\$event);
+	    LJ::EmbedModule->expand_entry($u, \$event, ('content_only' => 1));
+
+            $ppid = $1
+                if $event =~ m!<lj-phonepost journalid=['"]\d+['"] dpid=['"](\d+)['"] />!; #'
+        }
+
+        my $mood;
+        if ($props->{'current_mood'}) {
+            $mood = $props->{'current_mood'};
+        } elsif ($props->{'current_moodid'}) {
+            $mood = LJ::mood_name($props->{'current_moodid'}+0);
+        }
+  
+        if ($ljr) {
+          LJR::Distributed::sign_exported_rss_entry($u, $it->{'itemid'}, $it->{'anum'}, \$event);
+        }
+
+        my $createtime = $LJ::EndOfTime - $it->{rlogtime};
+
+        my $cleanitem = {
+            itemid     => $itemid,
+            ditemid    => $ditemid,
+            subject    => $subject,
+            event      => $event,
+            createtime => $createtime,
+            eventtime  => $it->{alldatepart},  # ugly: this is of a different format than the other two times.
+            modtime    => $props->{revtime} || $createtime,
+            comments   => ($props->{'opt_nocomments'} == 0),
+            music      => $props->{'current_music'},
+            mood       => $mood,
+            ppid       => $ppid,
+            tags       => $props->{'tags'},
+        };
+        push @cleanitems, $cleanitem;
+    }
+
+    # fix up the build date to use entry-time
+    # (empty journals show  01 Jan 1970 00:00:00 GMT as build date and Last-Modified time).
+    $journalinfo->{'builddate'} = LJ::time_to_http(@items ? $LJ::EndOfTime - $items[0]->{'rlogtime'} : 0),
+
+    return $viewfunc->($journalinfo, $u, $opts, \@cleanitems, $remote, $lastmod);
+}
+
+
+# the creator for the RSS XML syndication view
+sub create_view_rss
+{
+    my ($journalinfo, $u, $opts, $cleanitems, $remote, $lastmod) = @_;
+
+    my $ret;
+
+    # header
+    $ret .= "<?xml version='1.0' encoding='$opts->{'saycharset'}' ?>\n";
+    $ret .= LJ::run_hook("bot_director", "<!-- ", " -->") . "\n";
+    $ret .= "<rss version='2.0' xmlns:lj='http://www.livejournal.org/rss/lj/1.0/'>\n";
+
+    # channel attributes
+    $ret .= "<channel>\n";
+    $ret .= "  <title>" . LJ::exml($journalinfo->{title}) . "</title>\n";
+    $ret .= "  <link>$journalinfo->{link}</link>\n";
+    $ret .= "  <description>" . LJ::exml("$journalinfo->{title} - $LJ::SITENAME") . "</description>\n";
+    
+    if ($u->{'opt_blockrobots'}) {
+      $ret .= "  <copyright>noindex</copyright>\n";
+    }
+    
+    $ret .= "  <managingEditor>" . $journalinfo->{title} . "</managingEditor>\n" if $journalinfo->{email};
+    $ret .= "  <lastBuildDate>$journalinfo->{builddate}</lastBuildDate>\n";
+    $ret .= "  <generator>LiveJournal / $LJ::SITENAME</generator>\n";
+    # TODO: add 'language' field when user.lang has more useful information
+
+    ### image block, returns info for their current userpic
+    if ($u->{'defaultpicid'}) {
+        my $pic = {};
+        LJ::load_userpics($pic, [ $u, $u->{'defaultpicid'} ]);
+        $pic = $pic->{$u->{'defaultpicid'}}; # flatten
+        
+        $ret .= "  <image>\n";
+        $ret .= "    <url>$LJ::USERPIC_ROOT/$u->{'defaultpicid'}/$u->{'userid'}</url>\n";
+        $ret .= "    <title>" . LJ::exml($journalinfo->{title}) . "</title>\n";
+        $ret .= "    <link>$journalinfo->{link}</link>\n";
+        $ret .= "    <width>$pic->{'width'}</width>\n";
+        $ret .= "    <height>$pic->{'height'}</height>\n";
+        $ret .= "  </image>\n\n";
+    }
+
+    # output individual item blocks
+
+    foreach my $it (@$cleanitems) 
+    {
+        my $itemid = $it->{itemid};
+        my $ditemid = $it->{ditemid};
+        $ret .= "<item>\n";
+        $ret .= "  <guid isPermaLink='true'>$journalinfo->{link}$ditemid.html</guid>\n";
+        $ret .= "  <pubDate>" . LJ::time_to_http($it->{createtime}) . "</pubDate>\n";
+        $ret .= "  <title>" . LJ::exml($it->{subject}) . "</title>\n" if $it->{subject};
+## hide e-mail for security concern
+##        $ret .= "  <author>" . LJ::exml($journalinfo->{email}) . "</author>" if $journalinfo->{email};
+        $ret .= "  <link>$journalinfo->{link}$ditemid.html</link>\n";
+        # omit the description tag if we're only syndicating titles
+        #   note: the $event was also emptied earlier, in make_feed
+        unless ($u->{'opt_synlevel'} eq 'title') {
+            $ret .= "  <description>" . LJ::exml($it->{event}) . "</description>\n";
+        }
+        if ($it->{comments}) {
+            $ret .= "  <comments>$journalinfo->{link}$ditemid.html</comments>\n";
+        }
+        $ret .= "  <category>$_</category>\n" foreach map { LJ::exml($_) } @{$it->{tags} || []};
+        # support 'podcasting' enclosures
+        $ret .= LJ::run_hook( "pp_rss_enclosure",
+                { userid => $u->{userid}, ppid => $it->{ppid} }) if $it->{ppid};
+        # TODO: add author field with posterid's email address, respect communities
+        $ret .= "  <lj:music>" . LJ::exml($it->{music}) . "</lj:music>\n" if $it->{music};
+        $ret .= "  <lj:mood>" . LJ::exml($it->{mood}) . "</lj:mood>\n" if $it->{mood};
+        $ret .= "</item>\n";
+    }
+
+    $ret .= "</channel>\n";
+    $ret .= "</rss>\n";
+
+    #store to memcached, anonymous
+    LJ::MemCache::set([$u->{userid}, "rss:$u->{userid}"], {lastmod => $lastmod, text => $ret}) unless $remote;
+ 
+    return $ret;
+}
+
+
+# the creator for the Atom view
+# keys of $opts:
+# saycharset - required: the charset of the feed
+# noheader - only output an <entry>..</entry> block. off by default
+# apilinks - output AtomAPI links for posting a new entry or 
+#            getting/editing/deleting an existing one. off by default
+# TODO: define and use an 'lj:' namespace
+
+sub create_view_atom
+{
+    my ($journalinfo, $u, $opts, $cleanitems) = @_;
+
+    my $ret;
+
+    # prolog line
+    $ret .= "<?xml version='1.0' encoding='$opts->{'saycharset'}' ?>\n";
+    $ret .= LJ::run_hook("bot_director", "<!-- ", " -->");
+
+    # AtomAPI interface
+    my $api = $opts->{'apilinks'} ? "$LJ::SITEROOT/interface/atom" :
+                                    "$LJ::SITEROOT/users/$u->{user}/data/atom";
+
+    # header
+    unless ($opts->{'noheader'}) {
+        $ret .= "<feed version='0.3' xmlns='http://purl.org/atom/ns#'>\n";
+
+        # attributes
+        $ret .= "<title mode='escaped'>" . LJ::exml($journalinfo->{title}) . "</title>\n";
+        $ret .= "<tagline mode='escaped'>" . LJ::exml($journalinfo->{subtitle}) . "</tagline>\n"
+            if $journalinfo->{subtitle};
+        $ret .= "<link rel='alternate' type='text/html' href='$journalinfo->{link}' />\n";
+
+        # last update
+        $ret .= "<modified>" . LJ::time_to_w3c($journalinfo->{'modtime'}, 'Z')
+            . "</modified>";
+
+        # link to the AtomAPI version of this feed
+        $ret .= "<link rel='service.feed' type='application/x.atom+xml' title='";
+        $ret .= LJ::ehtml($journalinfo->{title});
+        $ret .= $opts->{'apilinks'} ? "' href='$api/feed' />" : "' href='$api' />";
+
+        if ($opts->{'apilinks'}) {
+            $ret .= "<link rel='service.post' type='application/x.atom+xml' title='Create a new post' href='$api/post' />";
+        }
+    }
+
+    # output individual item blocks
+
+    foreach my $it (@$cleanitems) 
+    {
+        my $itemid = $it->{itemid};
+        my $ditemid = $it->{ditemid};
+
+        $ret .= "  <entry xmlns=\"http://purl.org/atom/ns#\">\n";
+        # include empty tag if we don't have a subject.
+        $ret .= "    <title mode='escaped'>" . LJ::exml($it->{subject}) . "</title>\n";
+        $ret .= "    <id>urn:lj:$LJ::DOMAIN:atom1:$journalinfo->{u}{user}:$ditemid</id>\n";
+        $ret .= "    <link rel='alternate' type='text/html' href='$journalinfo->{link}$ditemid.html' />\n";
+        if ($opts->{'apilinks'}) {
+            $ret .= "<link rel='service.edit' type='application/x.atom+xml' title='Edit this post' href='$api/edit/$itemid' />";
+        }
+        $ret .= "    <created>" . LJ::time_to_w3c($it->{createtime}, 'Z') . "</created>\n"
+             if $it->{createtime} != $it->{modtime};
+
+        my ($year, $mon, $mday, $hour, $min, $sec) = split(/ /, $it->{eventtime});
+        $ret .= "    <issued>" .  sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
+                                          $year, $mon, $mday,
+                                          $hour, $min, $sec) .  "</issued>\n";
+        $ret .= "    <modified>" . LJ::time_to_w3c($it->{modtime}, 'Z') . "</modified>\n";
+        $ret .= "    <author>\n";
+        $ret .= "      <name>" . LJ::exml($journalinfo->{u}{name}) . "</name>\n";
+## hide e-mail for security concern
+##        $ret .= "      <email>" . LJ::exml($journalinfo->{email}) . "</email>\n" if $journalinfo->{email};
+        $ret .= "    </author>\n";
+        $ret .= "    <category term='$_' />\n" foreach map { LJ::exml($_) } @{$it->{tags} || []};
+        # if syndicating the complete entry
+        #   -print a content tag
+        # elsif syndicating summaries
+        #   -print a summary tag
+        # else (code omitted), we're syndicating title only
+        #   -print neither (the title has already been printed)
+        #   note: the $event was also emptied earlier, in make_feed
+        if ($u->{'opt_synlevel'} eq 'full') {
+            $ret .= "    <content type='text/html' mode='escaped'>" . LJ::exml($it->{event}) . "</content>\n";
+        } elsif ($u->{'opt_synlevel'} eq 'summary') {
+            $ret .= "    <summary type='text/html' mode='escaped'>" . LJ::exml($it->{event}) . "</summary>\n";
+        }
+
+        $ret .= "  </entry>\n";
+    }
+
+    unless ($opts->{'noheader'}) {
+        $ret .= "</feed>\n";
+    }
+
+    return $ret;
+}
+
+# create a FOAF page for a user
+sub create_view_foaf {
+    my ($journalinfo, $u, $opts) = @_;
+    my $comm = ($u->{journaltype} eq 'C');
+
+    my $ret;
+
+    # return nothing if we're not a user
+    unless ($u->{journaltype} eq 'P' || $comm) {
+        $opts->{handler_return} = 404;
+        return undef;
+    }
+
+    # set our content type
+    $opts->{contenttype} = 'application/rdf+xml; charset=' . $opts->{saycharset};
+
+    # setup userprops we will need
+    LJ::load_user_props($u, qw{
+        aolim icq yahoo jabber msn url urlname external_foaf_url
+    });
+
+    # create bare foaf document, for now
+    $ret = "<?xml version='1.0'?>\n";
+    $ret .= LJ::run_hook("bot_director", "<!-- ", " -->");
+    $ret .= "<rdf:RDF\n";
+    $ret .= "   xml:lang=\"en\"\n";
+    $ret .= "   xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n";
+    $ret .= "   xmlns:rdfs=\"http://www.w3.org/2000/01/rdf-schema#\"\n";
+    $ret .= "   xmlns:foaf=\"http://xmlns.com/foaf/0.1/\"\n";
+    $ret .= "   xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\n";
+
+    # precompute some values
+    my $digest = Digest::SHA1::sha1_hex('mailto:' . $u->{email});
+    
+    # channel attributes
+    $ret .= ($comm ? "  <foaf:Group>\n" : "  <foaf:Person>\n");
+    $ret .= "    <foaf:nick>$u->{user}</foaf:nick>\n";
+    if ($u->{bdate} && $u->{bdate} ne "0000-00-00" && !$comm && $u->{allow_infoshow} eq 'Y') {
+        my $bdate = $u->{bdate};
+        $bdate =~ s/^0000-//;
+        $ret .= "    <foaf:dateOfBirth>$bdate</foaf:dateOfBirth>\n";
+    }
+    $ret .= "    <foaf:mbox_sha1sum>$digest</foaf:mbox_sha1sum>\n";
+    $ret .= "    <foaf:page>\n";
+    $ret .= "      <foaf:Document rdf:about=\"$LJ::SITEROOT/userinfo.bml?user=$u->{user}\">\n";
+    $ret .= "        <dc:title>$LJ::SITENAME Profile</dc:title>\n";
+    $ret .= "        <dc:description>Full $LJ::SITENAME profile, including information such as interests and bio.</dc:description>\n";
+    $ret .= "      </foaf:Document>\n";
+    $ret .= "    </foaf:page>\n";
+
+    # we want to bail out if they have an external foaf file, because 
+    # we want them to be able to provide their own information. 
+    if ($u->{external_foaf_url}) {
+        $ret .= "    <rdfs:seeAlso rdf:resource=\"" . LJ::eurl($u->{external_foaf_url}) . "\" />\n";
+        $ret .= ($comm ? "  </foaf:Group>\n" : "  </foaf:Person>\n");
+        $ret .= "</rdf:RDF>\n";
+        return $ret;
+    }
+
+    # contact type information
+    my %types = (
+        aolim => 'aimChatID',
+        icq => 'icqChatID',
+        yahoo => 'yahooChatID',
+        msn => 'msnChatID',
+        jabber => 'jabberID',
+    );
+    if ($u->{allow_contactshow} eq 'Y') {
+        foreach my $type (keys %types) {
+            next unless $u->{$type};
+            $ret .= "    <foaf:$types{$type}>" . LJ::exml($u->{$type}) . "</foaf:$types{$type}>\n";
+        }
+    }
+
+    # include a user's journal page and web site info
+    $ret .= "    <foaf:weblog rdf:resource=\"" . LJ::journal_base($u) . "/\"/>\n";
+    if ($u->{url}) {
+        $ret .= "    <foaf:homepage rdf:resource=\"" . LJ::eurl($u->{url});
+        $ret .= "\" dc:title=\"" . LJ::exml($u->{urlname}) . "\" />\n";
+    }
+
+    # interests, please!
+    # arrayref of interests rows: [ intid, intname, intcount ]
+    my $intu = LJ::get_interests($u);
+    foreach my $int (@$intu) {
+        LJ::text_out(\$int->[1]); # 1==interest
+        $ret .= "    <foaf:interest dc:title=\"". LJ::exml($int->[1]) . "\" " .
+                "rdf:resource=\"$LJ::SITEROOT/interests.bml?int=" . LJ::eurl($int->[1]) . "\" />\n";
+    }
+
+    # check if the user has a "FOAF-knows" group
+    my $groups = LJ::get_friend_group($u->{userid}, { name => 'FOAF-knows' });
+    my $mask = $groups ? 1 << $groups->{groupnum} : 0;
+
+    # now information on who you know, limited to a certain maximum number of users
+    my $friends = LJ::get_friends($u->{userid}, $mask);
+    my @ids = keys %$friends;
+    @ids = splice(@ids, 0, $LJ::MAX_FOAF_FRIENDS) if @ids > $LJ::MAX_FOAF_FRIENDS;
+
+    # now load
+    my %users;
+    LJ::load_userids_multiple([ map { $_, \$users{$_} } @ids ], [$u]);
+
+    # iterate to create data structure
+    foreach my $friendid (@ids) {
+        next if $friendid == $u->{userid};
+        my $fu = $users{$friendid};
+        next if $fu->{statusvis} =~ /[DXS]/ || $fu->{journaltype} ne 'P';
+        $ret .= $comm ? "    <foaf:member>\n" : "    <foaf:knows>\n";
+        $ret .= "      <foaf:Person>\n";
+        $ret .= "        <foaf:nick>$fu->{'user'}</foaf:nick>\n";
+        $ret .= "        <rdfs:seeAlso rdf:resource=\"" . LJ::journal_base($fu) ."/data/foaf\" />\n";
+        $ret .= "        <foaf:weblog rdf:resource=\"" . LJ::journal_base($fu) . "/\"/>\n";
+        $ret .= "      </foaf:Person>\n";
+        $ret .= $comm ? "    </foaf:member>\n" : "    </foaf:knows>\n";
+    }
+
+    # finish off the document
+    $ret .= $comm ? "    </foaf:Group>\n" : "  </foaf:Person>\n";
+    $ret .= "</rdf:RDF>\n";
+
+    return $ret;
+}
+
+1;

local/cgi-bin/ljlang.pl

@@ -0,0 +1,418 @@
+#!/usr/bin/perl
+#
+
+use strict;
+use lib "$ENV{'LJHOME'}/cgi-bin";
+use LJ::Cache;
+
+package LJ::Lang;
+
+my @day_short   = (qw[Sun Mon Tue Wed Thu Fri Sat]);
+my @day_long    = (qw[Sunday Monday Tuesday Wednesday Thursday Friday Saturday]);
+my @month_short = (qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec]);
+my @month_long  = (qw[January February March April May June July August September October November December]);
+
+# get entire array of days and months
+sub day_list_short   { return @LJ::Lang::day_short;   }
+sub day_list_long    { return @LJ::Lang::day_long;    }
+sub month_list_short { return @LJ::Lang::month_short; }
+sub month_list_long  { return @LJ::Lang::month_long;  }
+
+# access individual day or month given integer
+sub day_short   { return   $day_short[$_[0] - 1]; }
+sub day_long    { return    $day_long[$_[0] - 1]; }
+sub month_short { return $month_short[$_[0] - 1]; }
+sub month_long  { return  $month_long[$_[0] - 1]; }
+
+# lang codes for individual day or month given integer
+sub day_short_langcode   { return "date.day."   . lc(LJ::Lang::day_long(@_))    . ".short"; }
+sub day_long_langcode    { return "date.day."   . lc(LJ::Lang::day_long(@_))    . ".long";  }
+sub month_short_langcode { return "date.month." . lc(LJ::Lang::month_long(@_))  . ".short"; }
+sub month_long_langcode  { return "date.month." . lc(LJ::Lang::month_long(@_))  . ".long";  }
+
+## ordinal suffix
+sub day_ord {
+    my $day = shift;
+
+    # teens all end in 'th'
+    if ($day =~ /1\d$/) { return "th"; }
+        
+    # otherwise endings in 1, 2, 3 are special
+    if ($day % 10 == 1) { return "st"; }
+    if ($day % 10 == 2) { return "nd"; }
+    if ($day % 10 == 3) { return "rd"; }
+
+    # everything else (0,4-9) end in "th"
+    return "th";
+}
+
+sub time_format
+{
+    my ($hours, $h, $m, $formatstring) = @_;
+
+    if ($formatstring eq "short") {
+        if ($hours == 12) {
+            my $ret;
+            my $ap = "a";
+            if ($h == 0) { $ret .= "12"; }
+            elsif ($h < 12) { $ret .= ($h+0); }
+            elsif ($h == 12) { $ret .= ($h+0); $ap = "p"; }
+            else { $ret .= ($h-12); $ap = "p"; }
+            $ret .= sprintf(":%02d$ap", $m);
+            return $ret;
+        } elsif ($hours == 24) {
+            return sprintf("%02d:%02d", $h, $m);
+        }
+    }
+    return "";
+}
+
+#### ml_ stuff:
+my $LS_CACHED = 0;
+my %DM_ID = ();     # id -> { type, args, dmid, langs => { => 1, => 0, => 1 } }
+my %DM_UNIQ = ();   # "$type/$args" => ^^^
+my %LN_ID = ();     # id -> { ..., ..., 'children' => [ $ids, .. ] }
+my %LN_CODE = ();   # $code -> ^^^^
+my $LAST_ERROR;
+my $TXT_CACHE;      # LJ::Cache for text
+
+sub get_cache_object { return $TXT_CACHE; }
+
+sub last_error
+{
+    return $LAST_ERROR;
+}
+
+sub set_error
+{
+    $LAST_ERROR = $_[0];
+    return 0;
+}
+
+sub get_lang
+{
+    my $code = shift;
+    load_lang_struct() unless $LS_CACHED;
+    return $LN_CODE{$code};
+}
+
+sub get_lang_id
+{
+    my $id = shift;
+    load_lang_struct() unless $LS_CACHED;
+    return $LN_ID{$id};
+}
+
+sub get_dom
+{
+    my $dmcode = shift;
+    load_lang_struct() unless $LS_CACHED;
+    return $DM_UNIQ{$dmcode};
+}
+
+sub get_dom_id
+{
+    my $dmid = shift;
+    load_lang_struct() unless $LS_CACHED;
+    return $DM_ID{$dmid};
+}
+
+sub get_domains
+{
+    load_lang_struct() unless $LS_CACHED;
+    return values %DM_ID;
+}
+
+sub get_root_lang
+{
+    my $dom = shift;  # from, say, get_dom
+    return undef unless ref $dom eq "HASH";
+    foreach (keys %{$dom->{'langs'}}) {
+        if ($dom->{'langs'}->{$_}) {
+            return get_lang_id($_);
+        }
+    }
+    return undef;
+}
+
+sub load_lang_struct
+{
+    return 1 if $LS_CACHED;
+    my $dbr = LJ::get_db_reader();
+    return set_error("No database available") unless $dbr;
+    my $sth;
+
+    $TXT_CACHE = new LJ::Cache { 'maxbytes' => $LJ::LANG_CACHE_BYTES || 50_000 };
+
+    $sth = $dbr->prepare("SELECT dmid, type, args FROM ml_domains");
+    $sth->execute;
+    while (my ($dmid, $type, $args) = $sth->fetchrow_array) {
+        my $uniq = $args ? "$type/$args" : $type;
+        $DM_UNIQ{$uniq} = $DM_ID{$dmid} = { 
+            'type' => $type, 'args' => $args, 'dmid' => $dmid,
+            'uniq' => $uniq,
+        };
+    }
+
+    $sth = $dbr->prepare("SELECT lnid, lncode, lnname, parenttype, parentlnid FROM ml_langs");
+    $sth->execute;
+    while (my ($id, $code, $name, $ptype, $pid) = $sth->fetchrow_array) {
+        $LN_ID{$id} = $LN_CODE{$code} = {
+            'lnid' => $id,
+            'lncode' => $code,
+            'lnname' => $name,
+            'parenttype' => $ptype,
+            'parentlnid' => $pid,
+        };
+    }
+    foreach (values %LN_CODE) {
+        next unless $_->{'parentlnid'};
+        push @{$LN_ID{$_->{'parentlnid'}}->{'children'}}, $_->{'lnid'};
+    }
+    
+    $sth = $dbr->prepare("SELECT lnid, dmid, dmmaster FROM ml_langdomains");
+    $sth->execute;
+    while (my ($lnid, $dmid, $dmmaster) = $sth->fetchrow_array) {
+        $DM_ID{$dmid}->{'langs'}->{$lnid} = $dmmaster;
+    }
+    
+    $LS_CACHED = 1;
+}
+
+sub get_itemid
+{
+    &LJ::nodb;
+    my ($dmid, $itcode, $opts) = @_;
+    load_lang_struct() unless $LS_CACHED;
+
+    my $dbr = LJ::get_db_reader();
+    $dmid += 0;
+    my $itid = $dbr->selectrow_array("SELECT itid FROM ml_items WHERE dmid=$dmid AND itcode=?", undef, $itcode);
+    return $itid if defined $itid;
+
+    my $dbh = LJ::get_db_writer();
+    return 0 unless $dbh;
+    
+    # allocate a new id
+    LJ::get_lock($dbh, 'global', 'mlitem_dmid') || return 0;
+    $itid = $dbh->selectrow_array("SELECT MAX(itid)+1 FROM ml_items WHERE dmid=?", undef, $dmid);
+    $itid ||= 1; # if the table is empty, NULL+1 == NULL
+    $dbh->do("INSERT INTO ml_items (dmid, itid, itcode, notes) ".
+             "VALUES (?, ?, ?, ?)", undef, $dmid, $itid, $itcode, $opts->{'notes'});
+    LJ::release_lock($dbh, 'global', 'mlitem_dmid');
+
+    if ($dbh->err) {
+        return $dbh->selectrow_array("SELECT itid FROM ml_items WHERE dmid=$dmid AND itcode=?",
+                                     undef, $itcode);
+    }
+    return $itid;
+}
+
+sub set_text
+{
+    &LJ::nodb;
+    my ($dmid, $lncode, $itcode, $text, $opts) = @_;
+    load_lang_struct() unless $LS_CACHED;
+
+    my $l = $LN_CODE{$lncode} or return set_error("Language not defined.");
+    my $lnid = $l->{'lnid'};
+    $dmid += 0;
+
+    # is this domain/language request even possible?
+    return set_error("Bogus domain") 
+        unless exists $DM_ID{$dmid};
+    return set_error("Bogus lang for that domain") 
+        unless exists $DM_ID{$dmid}->{'langs'}->{$lnid};
+
+    my $itid = get_itemid($dmid, $itcode, { 'notes' => $opts->{'notes'}});
+    return set_error("Couldn't allocate itid.") unless $itid;
+
+    my $dbh = LJ::get_db_writer();
+    my $txtid = 0;
+    if (defined $text) {
+        my $userid = $opts->{'userid'} + 0;
+        # Strip bad characters
+        $text =~ s/\r//;
+        my $qtext = $dbh->quote($text);
+        LJ::get_lock( $dbh, 'global', 'ml_text_txtid' ) || return 0;
+        $txtid = $dbh->selectrow_array("SELECT MAX(txtid)+1 FROM ml_text WHERE dmid=?", undef, $dmid);
+        $txtid ||= 1;
+        $dbh->do("INSERT INTO ml_text (dmid, txtid, lnid, itid, text, userid) ".
+                 "VALUES ($dmid, $txtid, $lnid, $itid, $qtext, $userid)");
+        LJ::release_lock( $dbh, 'global', 'ml_text_txtid' );
+        return set_error("Error inserting ml_text: ".$dbh->errstr) if $dbh->err;
+    }
+    if ($opts->{'txtid'}) {
+        $txtid = $opts->{'txtid'}+0;
+    }
+
+    my $staleness = $opts->{'staleness'}+0;
+    $dbh->do("REPLACE INTO ml_latest (lnid, dmid, itid, txtid, chgtime, staleness) ".
+             "VALUES ($lnid, $dmid, $itid, $txtid, NOW(), $staleness)");
+    return set_error("Error inserting ml_latest: ".$dbh->errstr) if $dbh->err;
+    LJ::MemCache::set("ml.${lncode}.${dmid}.${itcode}", $text) if defined $text;
+
+    {
+        my $vals;
+        my $langids;
+        my $rec = sub {
+            my $l = shift;
+            my $rec = shift;
+            foreach my $cid (@{$l->{'children'}}) {
+                my $clid = $LN_ID{$cid};
+                if ($opts->{'childrenlatest'}) {
+                    my $stale = $clid->{'parenttype'} eq "diff" ? 3 : 0;
+                    $vals .= "," if $vals;
+                    $vals .= "($cid, $dmid, $itid, $txtid, NOW(), $stale)";
+                }
+                $langids .= "," if $langids;
+                $langids .= $cid+0;
+                LJ::MemCache::delete("ml.$clid->{'lncode'}.${dmid}.${itcode}");
+                $rec->($clid, $rec);
+            }
+        };
+        $rec->($l, $rec);
+
+        # set descendants to use this mapping
+        $dbh->do("INSERT IGNORE INTO ml_latest (lnid, dmid, itid, txtid, chgtime, staleness) ".
+                 "VALUES $vals") if $vals;
+
+        # update languages that have no translation yet
+        $dbh->do("UPDATE ml_latest SET txtid=$txtid WHERE dmid=$dmid ".
+                 "AND lnid IN ($langids) AND itid=$itid AND staleness >= 3") if $langids;
+    }
+
+    if ($opts->{'changeseverity'} && $l->{'children'} && @{$l->{'children'}}) {
+        my $in = join(",", @{$l->{'children'}});
+        my $newstale = $opts->{'changeseverity'} == 2 ? 2 : 1;
+        $dbh->do("UPDATE ml_latest SET staleness=$newstale WHERE lnid IN ($in) AND ".
+                 "dmid=$dmid AND itid=$itid AND txtid<>$txtid AND staleness < $newstale");
+    }
+
+    return 1;
+}
+
+sub get_text
+{
+    my ($lang, $code, $dmid, $vars) = @_;
+    $dmid = int($dmid || 1);
+    $lang ||= $LJ::DEFAULT_LANG;
+    load_lang_struct() unless $LS_CACHED;
+    my $cache_key = "ml.${lang}.${dmid}.${code}";
+    
+    my $text = $TXT_CACHE->get($cache_key);
+
+    unless (defined $text) {
+        my $mem_good = 1;
+        $text = LJ::MemCache::get($cache_key);
+        unless (defined $text) {
+            $mem_good = 0;
+            my $l = $LN_CODE{$lang} or return "?lang?";
+            my $dbr = LJ::get_db_reader();
+            $text = $dbr->selectrow_array("SELECT t.text".
+                                          "  FROM ml_text t, ml_latest l, ml_items i".
+                                          " WHERE t.dmid=$dmid AND t.txtid=l.txtid".
+                                          "   AND l.dmid=$dmid AND l.lnid=$l->{lnid} AND l.itid=i.itid".
+                                          "   AND i.dmid=$dmid AND i.itcode=?", undef,
+                                          $code);
+        }
+        if (defined $text) {
+            $TXT_CACHE->set($cache_key, $text) unless $LJ::NO_ML_CACHE;
+            LJ::MemCache::set($cache_key, $text) unless $mem_good;
+        }
+    }
+
+    if ($vars) {
+        $text =~ s/\[\[\?([\w\-]+)\|(.+?)\]\]/resolve_plural($lang, $vars, $1, $2)/eg;
+        $text =~ s/\[\[([^\[]+?)\]\]/$vars->{$1}/g;
+    }
+    
+    $text =~ s/\[\[sitename\]\]/$LJ::SITENAME/g;
+
+    return $text;
+}
+
+# The translation system now supports the ability to add multiple plural forms of the word
+# given different rules in a languge.  This functionality is much like the plural support
+# in the S2 styles code.  To use this code you must use the BML::ml function and pass
+# the number of items as one of the variables.  To make sure that you are allowing the
+# utmost compatibility for each language you should not hardcode the placement of the
+# number of items in relation to the noun.  Let the translation string do this for you.
+# A translation string is in the format of, with num being the variable storing the
+# number of items.
+# =[[num]] [[?num|singular|plural1|plural2|pluralx]]
+
+sub resolve_plural {
+    my ($lang, $vars, $varname, $wordlist) = @_;
+    my $count = $vars->{$varname};
+    my @wlist = split(/\|/, $wordlist);
+    my $plural_form = plural_form($lang, $count);
+    return $wlist[$plural_form];
+}
+
+# TODO: make this faster, using AUTOLOAD and symbol tables pointing to dynamically
+# generated subs which only use $_[0] for $count.
+sub plural_form {
+    my ($lang, $count) = @_;
+    return plural_form_en($count) if $lang =~ /^en/;
+    return plural_form_ru($count) if $lang =~ /^ru/ || $lang =~ /^uk/;
+    return plural_form_fr($count) if $lang =~ /^fr/ || $lang =~ /^pt_BR/;
+    return plural_form_lt($count) if $lang =~ /^lt/;
+    return plural_form_pl($count) if $lang =~ /^pl/;
+    return plural_form_singular() if $lang =~ /^hu/ || $lang =~ /^ja/ || $lang =~ /^tr/;
+    return plural_form_lv($count) if $lang =~ /^lv/;
+    return plural_form_en($count);  # default
+}
+
+# English, Danish, German, Norwegian, Swedish, Estonian, Finnish, Greek, Hebrew, Italian, Portugese, Spanish, Esperanto
+sub plural_form_en {
+    my ($count) = shift;
+    return 0 if $count == 1;
+    return 1;
+}
+
+# French, Brazilian Portuguese
+sub plural_form_fr {
+    my ($count) = shift;
+    return 1 if $count > 1;
+    return 0;
+}
+
+# Croatian, Czech, Russian, Slovak, Ukrainian
+sub plural_form_ru {
+    my ($count) = shift;
+    return 0 if ($count%10 == 1 and $count%100 != 11);
+    return 1 if ($count%10 >= 2 and $count%10 <= 4 and ($count%100 < 10 or $count%100>=20));
+    return 2;
+}
+
+# Polish
+sub plural_form_pl {
+    my ($count) = shift;
+    return 0 if($count == 1);
+    return 1 if($count%10 >= 2 && $count%10 <= 4 && ($count%100 < 10 || $count%100 >= 20));
+    return 2;
+}
+
+# Lithuanian
+sub plural_form_lt {
+    my ($count) = shift;
+    return 0 if($count%10 == 1 && $count%100 != 11);
+    return 1 if ($count%10 >= 2 && ($count%100 < 10 || $count%100 >= 20));
+    return 2;
+}
+
+# Hungarian, Japanese, Korean (not supported), Turkish
+sub plural_form_singular {
+    return 0;
+}
+
+# Latvian
+sub plural_form_lv {
+    my ($count) = shift;
+    return 0 if($count%10 == 1 && $count%100 != 11);
+    return 1 if($count != 0);
+    return 2;
+}
+
+1;

local/cgi-bin/ljlib-local.pl

@@ -0,0 +1,114 @@
+require "$ENV{'LJHOME'}/cgi-bin/ljcom.pl";
+
+LJ::register_hook('emailconfirmed',
+  sub {
+    my $u = shift;
+    BML::set_cookie("LJR_confirmedemailthisyear", '1',
+      time() + 3600*24*365, $LJ::COOKIE_PATH, $LJ::COOKIE_DOMAIN);
+    return $text;
+  }
+);
+
+sub get_new_userid {
+  my $ruserid = 0; # scope
+
+  my $dbr = LJ::get_db_reader();
+
+  if (! $LJ::LJR_IMPORTED_USERIDS) {
+    $ruserid = $dbr->selectrow_array(
+      "select max(userid) from user"
+      );
+  }
+  else {
+    $ruserid = $dbr->selectrow_array(
+      "select max(userid) from user where userid < $LJ::LJR_IMPORTED_USERIDS"
+      );
+  }
+
+  if ($ruserid) {
+    $ruserid++;
+  }
+  
+  return $ruserid;
+}
+
+sub get_new_importedid {
+  my $ruserid = 0; # scope
+  my $dbr = LJ::get_db_reader();
+  $ruserid = $dbr->selectrow_array(
+    "select max(userid) from user where userid >= $LJ::LJR_IMPORTED_USERIDS",
+    );
+
+  if ($ruserid) {
+    $ruserid++;
+  }
+  else {
+    $ruserid = $LJ::LJR_IMPORTED_USERIDS;
+  }
+  
+  return $ruserid;
+}
+
+sub get_callstack {
+  my $cstack;
+  my $i = 0;
+  while ( 1 ) {
+    my $tfunc = (caller($i))[3];
+    if ($tfunc && $tfunc ne "") {
+      if ($tfunc !~ /\_\_ANON\_\_/) {
+        $cstack .= " " . $tfunc;
+      }
+      $i = $i + 1;
+    }
+    else {
+      last;
+    }
+  }
+  return $cstack;
+}
+
+# should be used when you need to concatenate string
+# which might be undefined and you want empty string ("")
+# instead of perl warnings about uninitialized values
+#
+sub safe_string {
+  my ($str) = @_;
+
+  if ($str) {
+    return $str;
+  }
+  else {
+    return "";
+  }
+}
+
+# check_unfriend
+# takes 2 userids, returns 1 if one unfriended another, 0 otherwise
+# args userid1, userid2
+
+sub check_twit
+{
+    my ($userid, $twitid) = @_;
+    return undef unless $userid;     return undef unless $twitid;
+    $dbh = LJ::get_db_reader();
+    return $err->("Can't get database reader!") unless $dbh;
+    my $sth = $dbh->prepare("SELECT * FROM twits WHERE".
+                       " userid=$userid AND twitid=$twitid");
+    $sth->execute() || print STDERR "Couldn't execute" . $sth->errstr;
+#    print STDERR "rows $sth->rows"; 
+    if ($sth->rows) { return 1;}  else {return 0;}
+}
+
+# takes userid, returns arrayref of its twitid's
+#
+sub get_twit_list
+{
+    my ($userid) = @_;
+    return undef unless $userid;
+
+    $db = LJ::get_db_reader();
+    return $err->("Can't get database reader!") unless $db;
+    return $db->selectcol_arrayref("SELECT twitid FROM
+               twits WHERE userid=?",  undef, $userid);
+}
+

local/cgi-bin/ljmail.pl

@@ -0,0 +1,356 @@
+#!/usr/bin/perl
+#
+# Send mail outbound using a weighted random selection.
+# Supports a variety of mail protocols.
+#
+
+package LJ;
+
+use strict;
+use Text::Wrap ();
+use MIME::Lite ();
+use Time::HiRes qw/ gettimeofday tv_interval /;
+
+use IO::Socket::INET (); # temp, for use with DMTP
+
+require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
+
+sub maildebug
+{
+    return unless $LJ::EMAIL_OUTGOING_DEBUG;
+    print STDERR "ljmail: " . shift() . "\n";
+}
+sub store_message
+{
+    my ( $data, $type ) = @_;
+    $type ||= 'none';
+
+    maildebug "Storing message for retry.";
+    my $time = [ gettimeofday() ];
+
+    # try this on each cluster
+    my $frozen = Storable::nfreeze($data);
+    my $rval   = LJ::do_to_cluster(
+        sub {
+            # first parameter is cluster id
+            return LJ::cmd_buffer_add( shift(@_), 0, 'send_mail', $frozen );
+        }
+    );
+    return undef unless $rval;
+
+    my $notes = sprintf(
+        "Queued mail send to %s %s: %s",
+        $data->get('to'), $rval ? "succeeded" : "failed",
+        $data->get('subject')
+    );
+    maildebug $notes;
+
+    LJ::blocking_report(
+        $type, 'send_mail',
+        tv_interval($time), $notes
+    );
+
+    # we only attempt to store the message
+    # on delivery failure.  if we're here, something
+    # failed, so always return false.
+    return 0;
+}
+
+# <LJFUNC>
+# name: LJ::send_mail
+# des: Sends email.  Character set will only be used if message is not ascii.
+# args: opt[, async_caller]
+# des-opt: Hashref of arguments.  <b>Required:</b> to, from, subject, body.
+#          <b>Optional:</b> toname, fromname, cc, bcc, charset, wrap
+# </LJFUNC>
+sub send_mail
+{
+    my $opts         = shift;
+    my $async_caller = shift;
+    my $time = [gettimeofday()];
+
+    my (
+        $proto,    # what protocol we decided to use
+        $msg,      # email message (ascii)
+        $data,     # email message (MIME::Lite)
+        $server,   # remote server object
+        $hostname  # hostname of mailserver selected
+    );
+
+    # support being given a direct MIME::Lite object,
+    # for queued cmdbuffer 'frozen' retries
+    $data = ( ref $opts eq 'MIME::Lite' ) ? $opts : build_message($opts);
+    return 0 unless $data;
+    $msg = $data->as_string();
+
+    # ok, we're sending via the network.
+    # get a preferred server/protocol, or failover to cmdbuffer.
+    ( $server, $proto, $hostname ) = find_server();
+    unless ( $server && $proto ) {
+        maildebug "Suitable mail transport not found.";
+        return store_message $data, undef;
+    }
+    my $info = "$hostname-$proto";
+
+    # Now we have an active server connection,
+    # and we know what protocol to use.
+
+    # clean addresses.
+    my ( @recips, %headers );
+    $headers{$_} = $data->get( $_ ) foreach qw/ from to cc bcc /;
+
+    $opts->{'from'} =
+        ( Mail::Address->parse( $data->get('from') ) )[0]->address()
+            if $headers{'from'};
+
+    push @recips, map { $_->address() } Mail::Address->parse( $headers{'to'} )  if $headers{'to'};
+    push @recips, map { $_->address() } Mail::Address->parse( $headers{'cc'} )  if $headers{'cc'};
+    push @recips, map { $_->address() } Mail::Address->parse( $headers{'bcc'} ) if $headers{'bcc'};
+
+    unless (scalar @recips) {
+        maildebug "No recipients to send to!";
+        return 0;
+    }
+
+    # QMTP
+    if ( $proto eq 'qmtp' ) {
+        $server->recipient($_) foreach @recips;
+        $server->sender( $opts->{'from'} );
+        $server->message($msg);
+
+        # send!
+        my $response = $server->send() or return store_message $data, $info;
+        foreach ( keys %$response ) {
+            return store_message $data, $info
+              if $response->{$_} !~ /success/;
+        }
+        $server->disconnect();
+    }
+
+    # SMTP
+    if ( $proto eq 'smtp' ) {
+
+        $server->mail( $opts->{'from'} );
+
+        # this would only fail on denied relay access
+        # or somesuch.
+        return store_message $data, $info unless 
+            $server->to( join ', ', @recips );
+
+        $server->data();
+        $server->datasend($msg);
+        $server->dataend();
+
+        $server->quit;
+    }
+
+    # DMTP (Danga Mail Transfer Protocol) 
+    # (slated for removal if our QMTP stuff is worry-free.)
+    if ( $proto eq 'dmtp' ) {
+
+        my $len = length $msg;
+        my $env = $opts->{'from'};
+
+        $server->print("Content-Length: $len\r\n");
+        $server->print("Envelope-Sender: $env\r\n\r\n$msg");
+
+        return store_message $data, $info
+            unless $server->getline() =~ /^OK/;
+    }
+
+    # system mailer
+    if ( $proto eq 'sendmail' ) {
+        MIME::Lite->send( 'sendmail', $hostname );
+        unless ( $data->send() ) {
+            maildebug "Unable to send via system mailer!";
+            return store_message $data, 'sendmail';
+        }
+    }
+
+    report( $data, $time, $info, $async_caller );
+    return 1;
+}
+
+sub report
+{
+    my ( $data, $time, $info, $async_caller ) = @_;
+
+    # report deliveries
+    my $notes = sprintf(
+        "Direct mail send to %s succeeded: %s",
+        $data->get('to') ||
+        $data->get('cc') ||
+        $data->get('bcc'), $data->get('subject')
+    );
+    maildebug $notes;
+
+    LJ::blocking_report(
+        $info, 'send_mail',
+        tv_interval( $time ), $notes
+      )
+      unless $async_caller;
+
+    return;
+}
+
+# locate a network server,
+# return (serverobj, protocol, hostname)
+sub find_server
+{
+    # operate on a copy of the server list.
+    my @objects = @LJ::MAIL_TRANSPORTS;
+
+    # backwards compatibility with earlier ljconfig.
+    unless (@objects) {
+        push @objects, [ 'sendmail', $LJ::SENDMAIL,    0 ] if $LJ::SENDMAIL;
+        push @objects, [ 'smtp',     $LJ::SMTP_SERVER, 0 ] if $LJ::SMTP_SERVER;
+        push @objects, [ 'dmtp',     $LJ::DMTP_SERVER, 1 ] if $LJ::DMTP_SERVER;
+    }
+
+    my ( $server, $proto, $hostname );
+
+    while ( @objects && !$proto ) {
+        my $item   = get_slice(@objects);
+        my $select = $objects[$item];
+
+        maildebug "Trying server $select->[1] ($select->[0])...";
+
+        # check service connectivity
+
+        # QMTP
+        if ( $select->[0] eq 'qmtp' ) {
+            eval 'use Net::QMTP';
+            if ($@) {
+                maildebug "Net::QMTP not installed?";
+                splice @objects, $item, 1;
+                next;
+            }
+
+            eval {
+                $server = Net::QMTP->new( $select->[1], ConnectTimeout => 10 );
+            };
+        }
+
+        # SMTP
+        elsif ( $select->[0] eq 'smtp' ) {
+            eval 'use Net::SMTP';
+            if ($@) {
+                maildebug "Net::SMTP not installed?";
+                splice @objects, $item, 1;
+                next;
+            }
+
+            eval { $server = Net::SMTP->new( $select->[1], Timeout => 10 ); };
+        }
+
+        # DMTP
+        elsif ( $select->[0] eq 'dmtp' ) {
+            my $host = $select->[1];
+            my $port = $host =~ s/:(\d+)$// ? $1 : 7005;
+
+            $server = IO::Socket::INET->new(
+                PeerAddr => $host,
+                PeerPort => $port,
+                Proto    => 'tcp'
+            );
+        }
+
+        # system sendmail binary
+        elsif ( $select->[0] eq 'sendmail' ) {
+            my $sendmail = $1 if $select->[1] =~ /(\S+)/;
+            $server = $sendmail if -e $sendmail && -x _;
+        }
+
+        else {
+            maildebug "Unknown mail protocol";
+            splice @objects, $item, 1;
+            next;
+        }
+
+        # do we have a server connection?
+        # if not, remove from our selection pool and try again.
+        if ( ! $server ) {
+            maildebug "Could not connect";
+            splice @objects, $item, 1;
+        }
+        else {
+            maildebug "Connected";
+            ( $proto, $hostname ) = ( $select->[0], $select->[1] );
+        }
+    }
+
+    return ( $server, $proto, $hostname );
+}
+
+# return a ready to stringify MIME::Lite object.
+sub build_message
+{
+    my $opts = shift;
+
+    local($Text::Tabs::columns) = 20000; ##temp hack; default 76
+
+    my $body = $opts->{'wrap'} ?
+               Text::Wrap::wrap( '', '', $opts->{'body'} ) :
+               $opts->{'body'};
+
+    my $to   = Mail::Address->new( $opts->{'toname'},   $opts->{'to'} );
+    my $from = Mail::Address->new( $opts->{'fromname'}, $opts->{'from'} );
+
+    my $msg = MIME::Lite->new
+        (
+         To      => $to->format(),
+         From    => $from->format(),
+         Cc      => $opts->{'cc'}  || '',
+         Bcc     => $opts->{'bcc'} || '',
+         Data    => "$body\n",
+         Subject => $opts->{'subject'},
+        );
+    return unless $msg;
+
+    $msg->add(%{ $opts->{'headers'} }) if ref $opts->{'headers'};
+
+    $msg->attr("content-type.charset" => $opts->{'charset'})
+        if $opts->{'charset'} &&
+           ! (LJ::is_ascii($opts->{'body'}) &&
+              LJ::is_ascii($opts->{'subject'}));
+
+    return $msg;
+}
+
+# return a weighted random slice from an array.
+sub get_slice
+{
+    my @objects = @_;
+
+    # Find cumulative values between weights, and in total.
+    my (@csums, $cumulative_sum);
+    @csums = map { $cumulative_sum += abs $_->[2] } @objects;
+
+    # *nothing* has weight? (all zeros?) just choose one.
+    # same thing as equal weights.
+    return int rand scalar @objects unless $cumulative_sum;
+
+    # Get a random number that will be compared to
+    # the 'window' of probability for quotes.
+    my $rand = rand $cumulative_sum;
+
+    # Create number ranges between each cumulative value,
+    # and check the random number to see if it falls within
+    # the weighted 'window size'.
+    # Remember the array slice for matching the original object to.
+    my $lastval = 0;
+    my $slice   = 0;
+    foreach (@csums) {
+        last if $rand >= $lastval && $rand <= $_;
+        $slice++;
+        $lastval = $_;
+    }
+
+    return $slice;
+}
+
+
+
+
+1;
+

local/cgi-bin/ljpoll.pl

@@ -0,0 +1,953 @@
+#!/usr/bin/perl
+#
+
+package LJ::Poll;
+
+use strict;
+use HTML::TokeParser ();
+
+require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
+require "$ENV{'LJHOME'}/cgi-bin/LJR/ljpoll-local.pl";
+
+sub clean_poll
+{
+    my $ref = shift;
+    if ($$ref !~ /[<>]/) {
+        LJ::text_out($ref);
+        return;
+    }
+
+    my $poll_eat = [qw[head title style layer iframe applet object]];
+    my $poll_allow = [qw[a b i u strong em img]];
+    my $poll_remove = [qw[bgsound embed object caption link font]];
+
+    LJ::CleanHTML::clean($ref, {
+        'wordlength' => 40,
+        'addbreaks' => 0,
+        'eat' => $poll_eat,
+        'mode' => 'deny',
+        'allow' => $poll_allow,
+        'remove' => $poll_remove,
+    });
+    LJ::text_out($ref);
+}
+
+
+sub contains_new_poll
+{
+    my $postref = shift;
+    return ($$postref =~ /<lj-poll\b/i);
+}
+
+sub parse
+{
+    &LJ::nodb;
+    my ($postref, $error, $iteminfo) = @_;
+
+    $iteminfo->{'posterid'} += 0;
+    $iteminfo->{'journalid'} += 0;
+
+    my $newdata;
+
+    my $popen = 0;
+    my %popts;
+
+    my $qopen = 0;
+    my %qopts;
+    
+    my $iopen = 0;
+    my %iopts;
+
+    my @polls;  # completed parsed polls
+
+    my $p = HTML::TokeParser->new($postref);
+
+    # if we're being called from mailgated, then we're not in web context and therefore
+    # do not have any BML::ml functionality.  detect this now and report errors in a 
+    # plaintext, non-translated form to be bounced via email.
+    my $have_bml = eval { BML::ml() } || ! $@;
+
+    my $err = sub {
+        # more than one element, either make a call to BML::ml
+        # or build up a semi-useful error string from it
+        if (@_ > 1) {
+            if ($have_bml) {
+                $$error = BML::ml(@_);
+                return 0;
+            }
+
+            $$error = shift() . ": ";
+            while (my ($k, $v) = each %{$_[0]}) {
+                $$error .= "$k=$v,";
+            }
+            chop $$error;
+            return 0;
+        }
+
+        # single element, either look up in %BML::ML or return verbatim
+        $$error = $have_bml ? $BML::ML{$_[0]} : $_[0];
+        return 0;
+    };
+
+    while (my $token = $p->get_token)    
+    {
+        my $type = $token->[0];
+        my $append;
+        
+        if ($type eq "S")     # start tag
+        {
+            my $tag = $token->[1];
+            my $opts = $token->[2];
+    
+            ######## Begin poll tag
+            
+            if ($tag eq "lj-poll") {
+                return $err->('poll.error.nested', { 'tag' => 'lj-poll' })
+                    if $popen;
+
+                $popen = 1;
+                %popts = ();
+                $popts{'questions'} = [];
+
+                $popts{'name'} = $opts->{'name'};
+                $popts{'whovote'} = lc($opts->{'whovote'}) || "all";
+                $popts{'whoview'} = lc($opts->{'whoview'}) || "all";
+
+                if ($popts{'whovote'} ne "all" && 
+                    $popts{'whovote'} ne "friends")
+                {
+                    return $err->('poll.error.whovote');
+                }
+                if ($popts{'whoview'} ne "all" && 
+                    $popts{'whoview'} ne "friends" &&
+                    $popts{'whoview'} ne "none")
+                {
+                    return $err->('poll.error.whoview');
+                }
+            }
+
+            ######## Begin poll question tag
+            
+            elsif ($tag eq "lj-pq") 
+            {
+                return $err->('poll.error.nested', { 'tag' => 'lj-pq' })
+                    if $qopen;
+
+                return $err->('poll.error.missingljpoll')
+                    unless $popen;
+
+                $qopen = 1;
+                %qopts = ();
+                $qopts{'items'} = [];
+
+                $qopts{'type'} = $opts->{'type'};
+                if ($qopts{'type'} eq "text") {
+                    my $size = 35;
+                    my $max = 255;
+                    if (defined $opts->{'size'}) {
+                        if ($opts->{'size'} > 0 &&
+                            $opts->{'size'} <= 100)
+                        {
+                            $size = $opts->{'size'}+0;
+                        } else {
+                            return $err->('poll.error.badsize');
+                        }
+                    }
+                    if (defined $opts->{'maxlength'}) {
+                        if ($opts->{'maxlength'} > 0 &&
+                            $opts->{'maxlength'} <= 255)
+                        {
+                            $max = $opts->{'maxlength'}+0;
+                        } else {
+                            return $err->('poll.error.badmaxlength');
+                        }
+                    }
+
+                    $qopts{'opts'} = "$size/$max";
+                }
+                if ($qopts{'type'} eq "scale") 
+                {
+                    my $from = 1;
+                    my $to = 10;
+                    my $by = 1;
+
+                    if (defined $opts->{'from'}) {
+                        $from = int($opts->{'from'});
+                    }
+                    if (defined $opts->{'to'}) {
+                        $to = int($opts->{'to'});
+                    }
+                    if (defined $opts->{'by'}) {
+                        $by = int($opts->{'by'});
+                    }
+                    if ($by < 1) {
+                        return $err->('poll.error.scaleincrement');
+                    }
+                    if ($from >= $to) {
+                        return $err->('poll.error.scalelessto');
+                    }
+                    if ((($to-$from)/$by) > 20) {
+                        return $err->('poll.error.scaletoobig');
+                    }
+                    $qopts{'opts'} = "$from/$to/$by";
+                }
+
+                $qopts{'type'} = lc($opts->{'type'}) || "text";
+
+                if ($qopts{'type'} ne "radio" &&
+                    $qopts{'type'} ne "check" &&
+                    $qopts{'type'} ne "drop" &&
+                    $qopts{'type'} ne "scale" &&
+                    $qopts{'type'} ne "text")
+                {
+                    return $err->('poll.error.unknownpqtype');
+                }
+                
+                
+            }
+
+            ######## Begin poll item tag
+
+            elsif ($tag eq "lj-pi")
+            {
+                if ($iopen) {
+                    return $err->('poll.error.nested', { 'tag' => 'lj-pi' });
+                }
+                if (! $qopen) {
+                    return $err->('poll.error.missingljpq');
+                }
+                if ($qopts{'type'} eq "text")
+                {
+                    return $err->('poll.error.noitemstext');
+                }
+                
+                $iopen = 1;
+                %iopts = ();
+            }   
+
+            #### not a special tag.  dump it right back out.
+
+            else 
+            {
+                $append .= "<$tag";
+                foreach (keys %$opts) {
+                    $append .= " $_=\"$opts->{$_}\"";
+                }
+                $append .= ">";
+            }
+        }
+        elsif ($type eq "E") 
+        {
+            my $tag = $token->[1];
+
+            ##### end POLL
+
+            if ($tag eq "lj-poll") {
+                return $err->('poll.error.tagnotopen', { 'tag' => 'lj-poll' })
+                    unless $popen;
+
+                $popen = 0;
+
+                return $err->('poll.error.noquestions')
+                    unless @{$popts{'questions'}};
+                
+                $popts{'journalid'} = $iteminfo->{'journalid'};
+                $popts{'posterid'} = $iteminfo->{'posterid'};
+                
+                push @polls, { %popts };
+
+                $append .= "<lj-poll-placeholder>";
+            } 
+
+            ##### end QUESTION
+
+            elsif ($tag eq "lj-pq") {
+                return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pq' })
+                    unless $qopen;
+
+                unless ($qopts{'type'} eq "scale" || 
+                        $qopts{'type'} eq "text" || 
+                        @{$qopts{'items'}}) 
+                {
+                    return $err->('poll.error.noitems');
+                }
+
+                $qopts{'qtext'} =~ s/^\s+//;
+                $qopts{'qtext'} =~ s/\s+$//;
+                my $len = length($qopts{'qtext'})
+                    or return $err->('poll.error.notext');
+
+                push @{$popts{'questions'}}, { %qopts };
+                $qopen = 0;
+                
+            }
+
+            ##### end ITEM
+
+            elsif ($tag eq "lj-pi") {
+                return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pi' })
+                    unless $iopen;
+
+                $iopts{'item'} =~ s/^\s+//;
+                $iopts{'item'} =~ s/\s+$//;
+
+                my $len = length($iopts{'item'});
+                return $err->('poll.error.pitoolong', { 'len' => $len, })
+                    if $len > 255 || $len < 1;
+
+                push @{$qopts{'items'}}, { %iopts };
+                $iopen = 0;
+            }
+            
+            ###### not a special tag.
+            
+            else
+            {
+                $append .= "</$tag>";
+            }
+        }
+        elsif ($type eq "T" || $type eq "D") 
+        {
+            $append = $token->[1];
+        } 
+        elsif ($type eq "C") {
+            # ignore comments
+        }
+        elsif ($type eq "PI") {
+            $newdata .= "<?$token->[1]>";
+        }
+        else {
+            $newdata .= "<!-- OTHER: " . $type . "-->\n";
+        }
+
+        ##### append stuff to the right place
+        if (length($append))
+        {
+            if ($iopen) {
+                $iopts{'item'} .= $append;
+            }
+            elsif ($qopen) {
+                $qopts{'qtext'} .= $append;
+            }
+            elsif ($popen) {
+                0;       # do nothing.
+            } else {
+                $newdata .= $append;
+            }
+        }
+
+    } 
+
+    if ($popen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-poll' }); }
+    if ($qopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pq' }); }
+    if ($iopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pi' }); }
+
+    $$postref = $newdata;
+    return @polls;
+}
+
+# preview poll
+#  -- accepts $poll hashref as found in the array returned by LJ::Poll::parse()
+sub preview {
+    my $poll = shift;
+    return unless ref $poll eq 'HASH';
+    
+    my $ret = '';
+    
+    $ret .= "<form action='#'>\n";
+    $ret .= "<b>" . BML::ml('poll.pollnum', { 'num' => 'xxxx' }) . "</b>";
+    if ($poll->{'name'}) {
+        LJ::Poll::clean_poll(\$poll->{'name'});
+        $ret .= " <i>$poll->{'name'}</i>";
+    }
+    $ret .= "<br />\n";
+    $ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$poll->{whovote}}, 'whoview' => $BML::ML{'poll.security.'.$poll->{whoview}}, });
+    
+    # iterate through all questions
+    foreach my $q (@{$poll->{'questions'}}) {
+        if ($q->{'qtext'}) {
+            LJ::Poll::clean_poll(\$q->{'qtext'});
+            $ret .= "<p>$q->{'qtext'}</p>\n";
+        }
+        $ret .= "<div style='margin: 10px 0 10px 40px'>";
+
+        # text questions
+        if ($q->{'type'} eq 'text') {
+            my ($size, $max) = split(m!/!, $q->{'opts'});
+            $ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max });
+
+        # scale questions
+        } elsif ($q->{'type'} eq 'scale') {
+            my ($from, $to, $by) = split(m!/!, $q->{'opts'});
+            $by ||= 1;
+            my $count = int(($to-$from)/$by) + 1;
+            my $do_radios = ($count <= 11);
+            
+            # few opts, display radios
+            if ($do_radios) {
+                $ret .= "<table><tr valign='top' align='center'>\n";
+                for (my $at = $from; $at <= $to; $at += $by) {
+                    $ret .= "<td>" . LJ::html_check({ 'type' => 'radio' }) . "<br />$at</td>\n";
+                }
+                $ret .= "</tr></table>\n";
+
+            # many opts, display select
+            } else {
+                my @optlist = ();
+                for (my $at = $from; $at <= $to; $at += $by) {
+                    push @optlist, ('', $at);
+                }
+                $ret .= LJ::html_select({}, @optlist);
+            }
+            
+        # questions with items
+        } else {
+
+            # drop-down list
+            if ($q->{'type'} eq 'drop') {
+                my @optlist = ('', '');
+                foreach my $it (@{$q->{'items'}}) {
+                    LJ::Poll::clean_poll(\$it->{'item'});
+                    push @optlist, ('', $it->{'item'});
+                }
+                $ret .= LJ::html_select({}, @optlist);
+
+
+            # radio or checkbox
+            } else {
+                foreach my $it (@{$q->{'items'}}) {
+                    LJ::Poll::clean_poll(\$it->{'item'});
+                    $ret .= LJ::html_check({ 'type' => $q->{'type'} }) . "$it->{'item'}<br />\n";
+                }
+            }
+        }
+        
+        $ret .= "</div>\n";
+        
+    }
+    
+    $ret .= LJ::html_submit('', $BML::ML{'poll.submit'}, { 'disabled' => 1 }) . "\n";
+    $ret .= "</form>";
+    
+    return $ret; 
+}
+
+# note: $itemid is a $ditemid (display itemid, *256 + anum)
+sub register
+{
+    &LJ::nodb;
+    my $dbh = LJ::get_db_writer();
+    my $post = shift;
+    my $error = shift;
+    my $itemid = shift;
+    my @polls = @_;
+    
+    foreach my $po (@polls)
+    {
+        my %popts = %$po;
+        $popts{'itemid'} = $itemid+0;
+
+        #### CREATE THE POLL!
+        
+        my $sth = $dbh->prepare("INSERT INTO poll (itemid, journalid, posterid, whovote, whoview, name) " .
+                                "VALUES (?, ?, ?, ?, ?, ?)");
+        $sth->execute($itemid, $popts{'journalid'}, $popts{'posterid'},
+                      $popts{'whovote'}, $popts{'whoview'}, $popts{'name'});
+        if ($dbh->err) {
+            $$error = BML::ml('poll.dberror', { errmsg => $dbh->errstr });
+            return 0;
+        }
+        my $pollid = $dbh->{'mysql_insertid'};
+
+        $$post =~ s/<lj-poll-placeholder>/<lj-poll-$pollid>/;  # NOT global replace!
+        
+        ## start inserting poll questions
+        my $qnum = 0;
+        foreach my $q (@{$popts{'questions'}})
+        {
+            $qnum++;
+            $sth = $dbh->prepare("INSERT INTO pollquestion (pollid, pollqid, sortorder, type, opts, qtext) " . 
+                                 "VALUES (?, ?, ?, ?, ?, ?)");
+            $sth->execute($pollid, $qnum, $qnum, $q->{'type'}, $q->{'opts'}, $q->{'qtext'});
+            if ($dbh->err) {
+                $$error = BML::ml('poll.dberror.questions', { errmsg => $dbh->errstr });
+                return 0;
+            }
+            
+            my $pollqid = $dbh->{'mysql_insertid'};
+            
+            ## start inserting poll items
+            my $inum = 0;
+            foreach my $it (@{$q->{'items'}}) {
+                $inum++;
+                $dbh->do("INSERT INTO pollitem (pollid, pollqid, pollitid, sortorder, item) " . 
+                         "VALUES (?, ?, ?, ?, ?)", undef, $pollid, $qnum, $inum, $inum, $it->{'item'});
+                if ($dbh->err) {
+                    $$error = BML::ml('poll.dberror.items', { errmsg => $dbh->errstr });
+                    return 0;
+                }
+            }
+            ## end inserting poll items
+            
+        }
+        ## end inserting poll questions
+        
+    }  ### end while over all poles
+
+}
+
+sub show_polls
+{
+    &LJ::nodb;
+    my $itemid = shift;
+    my $remote = shift;
+    my $postref = shift;
+
+    $$postref =~ s/<lj-poll-(\d+)>/&show_poll($itemid, $remote, $1)/eg;
+}
+
+sub show_poll
+{
+    &LJ::nodb;
+    my $dbr = LJ::get_db_reader();
+    my $itemid = shift;
+    my $remote = shift;
+    my $pollid = shift;
+    my $opts = shift;  # hashref.  {"mode" => results/enter/ans}
+    my $sth;
+
+    my $mode = $opts->{'mode'};
+    $pollid += 0;
+    
+    my $po = $dbr->selectrow_hashref("SELECT * FROM poll WHERE pollid=?", undef, $pollid);
+    return "<b>[" . BML::ml('poll.error.pollnotfound', { 'num' => $pollid }) . "]</b>" unless $po;
+    return "<b>[$BML::ML{'poll.error.noentry'}]</b>"
+        if $itemid && $po->{'itemid'} != $itemid;
+
+    my ($can_vote, $can_view) = find_security($po, $remote);
+
+    # update the mode if we need to
+    $mode = 'results' unless $remote;
+    if (!$mode && $remote) {
+        my $time = $dbr->selectrow_array('SELECT datesubmit FROM pollsubmission '.
+                                         'WHERE pollid=? AND userid=?', undef, $pollid, $remote->{userid});
+        $mode = $time ? 'results' : $can_vote ? 'enter' : 'results';
+    }
+
+    ### load all the questions
+    my @qs;
+    $sth = $dbr->prepare('SELECT * FROM pollquestion WHERE pollid=?');
+    $sth->execute($pollid);
+    push @qs, $_ while $_ = $sth->fetchrow_hashref;
+    @qs = sort { $a->{sortorder} <=> $b->{sortorder} } @qs;
+
+    ### load all the items
+    my %its;
+    $sth = $dbr->prepare("SELECT pollqid, pollitid, item FROM pollitem WHERE pollid=? ORDER BY sortorder");
+    $sth->execute($pollid);
+    while (my ($qid, $itid, $item) = $sth->fetchrow_array) {
+        push @{$its{$qid}}, [ $itid, $item ];
+    }
+
+    # see if we have a hook for alternate poll contents
+    my $ret = LJ::run_hook('alternate_show_poll_html', $po, $mode, \@qs);
+    return $ret if $ret;
+
+    ### view answers to a particular question in a poll
+    if ($mode eq "ans") 
+    {
+        return "<b>[$BML::ML{'poll.error.cantview'}]</b>"
+            unless $can_view;
+
+        # get the question from @qs, which we loaded earlier
+        my $q;
+        foreach (@qs) {
+            $q = $_ if $_->{pollqid} == $opts->{qid};
+        }
+        return "<b>[$BML::ML{'poll.error.questionnotfound'}]</b>"
+            unless $q;
+
+        # get the item information from %its, also loaded earlier
+        my %it;
+        $it{$_->[0]} = $_->[1] foreach (@{$its{$opts->{qid}}});
+
+        LJ::Poll::clean_poll(\$q->{'qtext'});
+        $ret .= $q->{'qtext'};
+        $ret .= "<p>";
+
+        my $LIMIT = 2000;
+        $sth = $dbr->prepare("SELECT u.user, pr.value, ps.datesubmit ".
+                             "FROM useridmap u, pollresult pr, pollsubmission ps " . 
+                             "WHERE u.userid=pr.userid AND pr.pollid=? AND pollqid=? " . 
+                             "AND ps.pollid=pr.pollid AND ps.userid=pr.userid LIMIT $LIMIT");
+        $sth->execute($pollid, $opts->{'qid'});
+
+        my @res;
+        push @res, $_ while $_ = $sth->fetchrow_hashref;
+        @res = sort { $a->{datesubmit} cmp $b->{datesubmit} } @res;
+        
+        foreach my $res (@res) {
+            my ($user, $value) = ($res->{user}, $res->{value});
+            
+            ## some question types need translation; type 'text' doesn't.
+            if ($q->{'type'} eq "radio" || $q->{'type'} eq "drop") {
+                $value = $it{$value};
+            }
+            elsif ($q->{'type'} eq "check") {
+                $value = join(", ", map { $it{$_} } split(/,/, $value));
+            }
+
+            LJ::Poll::clean_poll(\$value);
+            $ret .= "<p>" . LJ::ljuser($user) . " -- $value</p>\n";
+        }
+
+        # temporary
+        if (@res == $LIMIT) {
+            $ret .= "<p>[$BML::ML{'poll.error.truncated'}]</p>";
+        }
+        
+        return $ret;
+    }
+
+    # Users cannot vote unless they are logged in
+    return "<?needlogin?>"
+        if $mode eq 'enter' && !$remote;
+
+    my $do_form = $mode eq 'enter' && $can_vote;
+    my %preval;
+
+    if ($do_form) {
+        $sth = $dbr->prepare("SELECT pollqid, value FROM pollresult WHERE pollid=? AND userid=?");
+        $sth->execute($pollid, $remote->{'userid'});
+        while (my ($qid, $value) = $sth->fetchrow_array) {
+            $preval{$qid} = $value;
+        }
+
+        $ret .= "<form action='$LJ::SITEROOT/poll/?id=$pollid' method='post'>";
+        $ret .= LJ::form_auth();
+        $ret .= LJ::html_hidden('pollid', $pollid);
+    }
+
+    $ret .= "<b><a href='$LJ::SITEROOT/poll/?id=$pollid'>" . BML::ml('poll.pollnum', { 'num' => $pollid }) . "</a></b> ";
+    if ($po->{'name'}) {
+        LJ::Poll::clean_poll(\$po->{'name'});
+        $ret .= "<i>$po->{'name'}</i>";
+    }
+    $ret .= "<br />\n";
+    $ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$po->{whovote}}, 
+                                       'whoview' => $BML::ML{'poll.security.'.$po->{whoview}} }); 
+    my $text = LJ::run_hook('extra_poll_description', $po, \@qs);
+    $ret .= "<br />$text" if $text;
+
+    ## go through all questions, adding to buffer to return
+    foreach my $q (@qs)
+    {
+        my $qid = $q->{'pollqid'};
+        LJ::Poll::clean_poll(\$q->{'qtext'});
+        $ret .= "<p>$q->{'qtext'}</p><div style='margin: 10px 0 10px 40px'>";
+        
+        ### get statistics, for scale questions
+        my ($valcount, $valmean, $valstddev, $valmedian);
+        if ($q->{'type'} eq "scale") 
+        {
+            ## manually add all the possible values, since they aren't in the database
+            ## (which was the whole point of making a "scale" type):
+            my ($from, $to, $by) = split(m!/!, $q->{'opts'});
+            $by = 1 unless ($by > 0 and int($by) == $by);
+            for (my $at=$from; $at<=$to; $at+=$by) {
+                push @{$its{$qid}}, [ $at, $at ];  # note: fake itemid, doesn't matter, but needed to be unique
+            }
+
+            $sth = $dbr->prepare("SELECT COUNT(*), AVG(value), STDDEV(value) FROM pollresult WHERE pollid=? AND pollqid=?");
+            $sth->execute($pollid, $qid);
+            ($valcount, $valmean, $valstddev) = $sth->fetchrow_array;
+            
+            # find median:
+            $valmedian = 0;
+            if ($valcount == 1) { 
+                $valmedian = $valmean;
+            } elsif ($valcount > 1) {
+                my ($mid, $fetch);
+                # fetch two mids and average if even count, else grab absolute middle
+                $fetch = ($valcount % 2) ? 1 : 2;
+                $mid = int(($valcount+1)/2);
+                my $skip = $mid-1;
+
+                $sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=? " .
+                                     "ORDER BY value+0 LIMIT $skip,$fetch");
+                $sth->execute($pollid, $qid);
+                while (my ($v) = $sth->fetchrow_array) {
+                    $valmedian += $v;
+                }
+                $valmedian /= $fetch;
+            }
+        }
+
+        my $usersvoted = 0;
+        my %itvotes;
+        my $maxitvotes = 1;
+
+        if ($mode eq "results")
+        {
+            ### to see individual's answers
+            $ret .= "<a href='$LJ::SITEROOT/poll/?id=$pollid&amp;qid=$qid&amp;mode=ans'>$BML::ML{'poll.viewanswers'}</a><br />";
+
+            ### but, if this is a non-text item, and we're showing results, need to load the answers:
+            if ($q->{'type'} ne "text") {
+                $sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=?");
+                $sth->execute($pollid, $qid);
+                while (my ($val) = $sth->fetchrow_array) {
+                    $usersvoted++;
+                    if ($q->{'type'} eq "check") {
+                        foreach (split(/,/,$val)) {
+                            $itvotes{$_}++;
+                        }
+                    } else {
+                        $itvotes{$val}++;
+                    }
+                }
+                
+                foreach (values %itvotes) {
+                    $maxitvotes = $_ if ($_ > $maxitvotes);
+                }
+            }
+        }
+
+        #### text questions are the easy case
+
+        if ($q->{'type'} eq "text" && $do_form) {
+            my ($size, $max) = split(m!/!, $q->{'opts'});
+
+            $ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max, 
+                                    'name' => "pollq-$qid", 'value' => $preval{$qid} });
+        }
+
+        #### drop-down list
+        elsif ($q->{'type'} eq 'drop' && $do_form) {
+            my @optlist = ('', '');
+            foreach my $it (@{$its{$qid}}) {
+                my ($itid, $item) = @$it;
+                LJ::Poll::clean_poll(\$item);
+                push @optlist, ($itid, $item);
+            }
+            $ret .= LJ::html_select({ 'name' => "pollq-$qid", 
+                                      'selected' => $preval{$qid} }, @optlist);
+        }
+
+        #### scales (from 1-10) questions
+
+        elsif ($q->{'type'} eq "scale" && $do_form) {
+            my ($from, $to, $by) = split(m!/!, $q->{'opts'});
+            $by ||= 1;
+            my $count = int(($to-$from)/$by) + 1;
+            my $do_radios = ($count <= 11);
+
+            # few opts, display radios
+            if ($do_radios) {
+
+                $ret .= "<table><tr valign='top' align='center'>";
+
+                for (my $at=$from; $at<=$to; $at+=$by) {
+                    $ret .= "<td style='text-align: center;'>";
+                    $ret .= LJ::html_check({ 'type' => 'radio', 'name' => "pollq-$qid",
+                                             'value' => $at, 'id' => "pollq-$pollid-$qid-$at",
+                                             'selected' => (defined $preval{$qid} && $at == $preval{$qid}) });
+                    $ret .= "<br /><label for='pollq-$pollid-$qid-$at'>$at</label></td>";
+                }
+
+                $ret .= "</tr></table>\n";
+
+            # many opts, display select
+            # but only if displaying form
+            } else {
+
+                my @optlist = ('', '');
+                for (my $at=$from; $at<=$to; $at+=$by) {
+                    push @optlist, ($at, $at);
+                }
+                $ret .= LJ::html_select({ 'name' => "pollq-$qid", 'selected' => $preval{$qid} }, @optlist);
+            }
+
+        }
+
+        #### now, questions with items
+
+        else
+        {
+            my $do_table = 0;
+
+            if ($q->{'type'} eq "scale") { # implies ! do_form
+                my $stddev = sprintf("%.2f", $valstddev);
+                my $mean = sprintf("%.2f", $valmean);
+                $ret .= BML::ml('poll.scaleanswers', { 'mean' => $mean, 'median' => $valmedian, 'stddev' => $stddev });
+                $ret .= "<br />\n";
+                $do_table = 1;
+                $ret .= "<table>";
+            }
+
+            foreach my $it (@{$its{$qid}})
+            {
+                my ($itid, $item) = @$it;
+                LJ::Poll::clean_poll(\$item);
+
+                # displaying a radio or checkbox
+                if ($do_form) {
+                    $ret .= LJ::html_check({ 'type' => $q->{'type'}, 'name' => "pollq-$qid",
+                                             'value' => $itid, 'id' => "pollq-$pollid-$qid-$itid",
+                                             'selected' => ($preval{$qid} =~ /\b$itid\b/) });
+                    $ret .= " <label for='pollq-$pollid-$qid-$itid'>$item</label><br />";
+                    next;
+                }
+
+                # displaying results
+                my $count = $itvotes{$itid}+0;
+                my $percent = sprintf("%.1f", (100 * $count / ($usersvoted||1)));
+                my $width = 20+int(($count/$maxitvotes)*380);
+
+                if ($do_table) {
+                    $ret .= "<tr valign='middle'><td align='right'>$item</td>";
+                    $ret .= "<td><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
+                    $ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
+                    $ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
+                    $ret .= "<b>$count</b> ($percent%)</td></tr>";
+                } else {
+                    $ret .= "<p>$item<br />";
+                    $ret .= "<span style='white-space: nowrap'><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
+                    $ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
+                    $ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
+                    $ret .= "<b>$count</b> ($percent%)</span></p>";
+                }
+            }
+
+            if ($do_table) {
+                $ret .= "</table>";
+            }
+
+        }
+
+        $ret .= "</div>";
+    }
+    
+    if ($do_form) {
+        $ret .= LJ::html_submit('poll-submit', $BML::ML{'poll.submit'}) . "</form>\n";;
+    }
+    
+    return $ret;
+}
+
+sub find_security
+{
+    &LJ::nodb;
+
+    my $po = shift;
+    my $remote = shift;
+    my $sth;
+
+    ## if remote is poll owner, can do anything.
+    if ($remote && $remote->{'userid'} == $po->{'posterid'}) {
+        return (1, 1);
+    }
+
+    ## need to be both a person and with a visible journal to vote
+    if ($remote &&
+        ($remote->{'journaltype'} ne "P" || $remote->{'statusvis'} ne "V")) {
+        return (0, 0);
+    }
+
+    my $is_friend = 0;
+    if (($po->{'whoview'} eq "friends" || 
+         $po->{'whovote'} eq "friends") && $remote)
+    {
+        $is_friend = LJ::is_friend($po->{'journalid'}, $remote->{'userid'});
+    }
+
+    my %sec;
+    if ($po->{'whoview'} eq "all" ||
+        ($po->{'whoview'} eq "friends" && $is_friend) ||
+        ($po->{'whoview'} eq "none" && $remote && $remote->{'userid'} == $po->{'posterid'}))
+    {
+        $sec{'view'} = 1;
+    }
+
+    if ($po->{'whovote'} eq "all" ||
+        ($po->{'whovote'} eq "friends" && $is_friend))
+    {
+        $sec{'vote'} = 1;
+    }
+
+    if ($sec{'vote'} && (LJ::is_banned($remote, $po->{'journalid'}) ||
+                         LJ::is_banned($remote, $po->{'posterid'}))) {
+        $sec{'vote'} = 0;
+    }
+    
+    return ($sec{'vote'}, $sec{'view'});
+}
+
+sub submit
+{
+    &LJ::nodb;
+    
+    my $remote = shift;
+    my $form = shift;
+    my $error = shift;
+    my $sth;
+
+    my $dbh = LJ::get_db_writer();
+
+    unless ($remote) {
+        $$error = $BML::ML{'error.noremote'}; # instead of <?needremote?>, because errors are displayed in LJ::bad_input()
+        return 0;
+    }
+
+    my $pollid = $form->{'pollid'}+0;
+    my $po = $dbh->selectrow_hashref("SELECT itemid, whovote, journalid, posterid, whoview, whovote, name ".
+                                     "FROM poll WHERE pollid=?", undef, $pollid);
+    unless ($po) {
+        $$error = $BML::ML{'poll.error.nopollid'};
+        return 0;	
+    }
+    
+    my ($can_vote, undef) = find_security($po, $remote);
+
+    unless ($can_vote) {
+        $$error = $BML::ML{'poll.error.cantvote'};
+        return 0;
+    }
+
+    ### load all the questions
+    my @qs;
+    $sth = $dbh->prepare("SELECT pollqid, type, opts, qtext FROM pollquestion WHERE pollid=?");
+    $sth->execute($pollid);
+    push @qs, $_ while $_ = $sth->fetchrow_hashref;
+    
+    foreach my $q (@qs) {
+        my $qid = $q->{'pollqid'}+0;
+        my $val = $form->{"pollq-$qid"};
+        if ($q->{'type'} eq "check") {
+            ## multi-selected items are comma separated from htdocs/poll/index.bml
+            $val = join(",", sort { $a <=> $b } split(/,/, $val));
+        }
+        if ($q->{'type'} eq "scale") {
+            my ($from, $to, $by) = split(m!/!, $q->{'opts'});
+            if ($val < $from || $val > $to) { 
+                # bogus! cheating?
+                $val = "";
+            }
+        }
+        if ($val ne "") {
+            $dbh->do("REPLACE INTO pollresult (pollid, pollqid, userid, value) VALUES (?, ?, ?, ?)",
+                     undef, $pollid, $qid, $remote->{'userid'}, $val);
+        } else {
+            $dbh->do("DELETE FROM pollresult WHERE pollid=? AND pollqid=? AND userid=?",
+                     undef, $pollid, $qid, $remote->{'userid'});
+        }
+    }
+    
+    ## finally, register the vote happened
+    $dbh->do("REPLACE INTO pollsubmission (pollid, userid, datesubmit) VALUES (?, ?, NOW())",
+             undef, $pollid, $remote->{'userid'});
+
+    return 1;
+}
+
+1;

local/cgi-bin/ljr_readconf.pl

@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+#
+#
+#
+#
+
+{
+  package LJ;
+
+  %LJR_REVERSE_PROXIES = (
+    "127.0.0.1" => 1,
+    "127.0.0.2" => 1,
+  );
+  eval {
+    open (t1, "cat $ENV{'LJHOME'}/etc/reverse-proxy.conf 2> /dev/null | ");
+    while(<t1>) {
+      my $cline = $_;
+      $cline =~ s/(#.*)//;
+      if ($cline =~ /([\d]+\.[\d]+\.[\d]+\.[\d]+)/) {
+        $LJR_REVERSE_PROXIES{$1} = 1;
+      }
+    }
+    close t1;
+  };
+
+  sub get_real_remote_ip {
+    my @ips_in = @_;
+
+    my @ips;
+    foreach my $i (@ips_in) {
+      while ($i =~ /([\d]+\.[\d]+\.[\d]+\.[\d]+)/g) {
+        push @ips, $1;
+      }
+    }
+    my $ip;
+    foreach $ip (@ips) {
+      if (scalar(%LJ::LJR_REVERSE_PROXIES)) {
+        if ($LJ::LJR_REVERSE_PROXIES{$ip}) {
+          next;
+        }
+        return $ip;
+      }
+      else {
+        return $ip;
+      }
+    }
+    return $ip; # in case we access server right from the proxy
+  }
+
+  sub filter_out_ip {
+    my ($real_ip, @ips_in) = @_;
+    my @ips;
+    foreach my $i (@ips_in) {
+      while ($i =~ /([\d]+\.[\d]+\.[\d]+\.[\d]+)/g) {
+        my $t = $1;
+        if ($t ne $real_ip) {
+          push @ips, $t;
+        }
+      }
+    }
+    return @ips;
+  }
+
+}
+
+return 1;

local/cgi-bin/ljtextutil.pl

@@ -0,0 +1,616 @@
+package LJ;
+use strict;
+no warnings 'uninitialized';
+
+use Class::Autouse qw(
+                      LJ::ConvUTF8
+                      HTML::TokeParser
+                      );
+
+# <LJFUNC>
+# name: LJ::trim
+# class: text
+# des: Removes whitespace from left and right side of a string.
+# args: string
+# des-string: string to be trimmed
+# returns: trimmed string
+# </LJFUNC>
+sub trim
+{
+    my $a = $_[0];
+    $a =~ s/^\s+//;
+    $a =~ s/\s+$//;
+    return $a;
+}
+
+# <LJFUNC>
+# name: LJ::decode_url_string
+# class: web
+# des: Parse URL-style arg/value pairs into a hash.
+# args: buffer, hashref
+# des-buffer: Scalar or scalarref of buffer to parse.
+# des-hashref: Hashref to populate.
+# returns: boolean; true.
+# </LJFUNC>
+sub decode_url_string
+{
+    my $a = shift;
+    my $buffer = ref $a ? $a : \$a;
+    my $hashref = shift;  # output hash
+    my $keyref  = shift;  # array of keys as they were found
+
+    my $pair;
+    my @pairs = split(/&/, $$buffer);
+    @$keyref = @pairs;
+    my ($name, $value);
+    foreach $pair (@pairs)
+    {
+        ($name, $value) = split(/=/, $pair);
+        $value =~ tr/+/ /;
+        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $name =~ tr/+/ /;
+        $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $hashref->{$name} .= $hashref->{$name} ? "\0$value" : $value;
+    }
+    return 1;
+}
+
+# args: hashref of key/values
+#       arrayref of keys in order (optional)
+# returns: urlencoded string
+sub encode_url_string {
+    my ($hashref, $keyref) = @_;
+
+    return join('&', map { LJ::eurl($_) . '=' . LJ::eurl($hashref->{$_}) }
+                (ref $keyref ? @$keyref : keys %$hashref));
+}
+
+# <LJFUNC>
+# name: LJ::eurl
+# class: text
+# des: Escapes a value before it can be put in a URL.  See also [func[LJ::durl]].
+# args: string
+# des-string: string to be escaped
+# returns: string escaped
+# </LJFUNC>
+sub eurl
+{
+    my $a = $_[0];
+    return '' unless $a;
+    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
+    $a =~ tr/ /+/;
+    return $a;
+}
+
+# <LJFUNC>
+# name: LJ::durl
+# class: text
+# des: Decodes a value that's URL-escaped.  See also [func[LJ::eurl]].
+# args: string
+# des-string: string to be decoded
+# returns: string decoded
+# </LJFUNC>
+sub durl
+{
+    my ($a) = @_;
+    $a =~ tr/+/ /;
+    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+    return $a;
+}
+
+# <LJFUNC>
+# name: LJ::exml
+# class: text
+# des: Escapes a value before it can be put in XML.
+# args: string
+# des-string: string to be escaped
+# returns: string escaped.
+# </LJFUNC>
+sub exml
+{
+    # fast path for the commmon case:
+    return $_[0] unless $_[0] =~ /[&\"\'<>\x00-\x08\x0B\x0C\x0E-\x1F]/;
+    # what are those character ranges? XML 1.0 allows:
+    # #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
+
+    my $a = shift;
+    $a =~ s/\&/&amp;/g;
+    $a =~ s/\"/&quot;/g;
+    $a =~ s/\'/&apos;/g;
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    $a =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g;
+    return $a;
+}
+
+# <LJFUNC>
+# name: LJ::ehtml
+# class: text
+# des: Escapes a value before it can be put in HTML.
+# args: string
+# des-string: string to be escaped
+# returns: string escaped.
+# </LJFUNC>
+sub ehtml
+{
+    # fast path for the commmon case:
+    return $_[0] unless $_[0] =~ /[&\"\'<>]/;
+
+    # this is faster than doing one substitution with a map:
+    my $a = $_[0];
+    $a =~ s/\&/&amp;/g;
+    $a =~ s/\"/&quot;/g;
+    $a =~ s/\'/&\#39;/g;
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    return $a;
+}
+*eall = \&ehtml;  # old BML syntax required eall to also escape BML.  not anymore.
+
+# <LJFUNC>
+# name: LJ::etags
+# class: text
+# des: Escapes < and > from a string
+# args: string
+# des-string: string to be escaped
+# returns: string escaped.
+# </LJFUNC>
+sub etags
+{
+    # fast path for the commmon case:
+    return $_[0] unless $_[0] =~ /[<>]/;
+
+    my $a = $_[0];
+    $a =~ s/</&lt;/g;
+    $a =~ s/>/&gt;/g;
+    return $a;
+}
+
+# <LJFUNC>
+# name: LJ::ejs
+# class: text
+# des: Escapes a string value before it can be put in JavaScript.
+# args: string
+# des-string: string to be escaped
+# returns: string escaped.
+# </LJFUNC>
+sub ejs
+{
+    my $a = $_[0];
+    $a =~ s/[\"\'\\]/\\$&/g;
+    $a =~ s/&quot;/\\&quot;/g;
+    $a =~ s/\r?\n/\\n/gs;
+    $a =~ s/\r//gs;
+    return $a;
+}
+
+# given a string, makes it into a string you can put into javascript,
+# including protecting against closing </script> tags in the entry.
+# does the double quotes for ya.
+sub ejs_string {
+    my $str = ejs($_[0]);
+    $str =~ s!</script!</scri\" + \"pt!g;
+    return "\"" . $str . "\"";
+}
+
+# changes every char in a string to %XX where XX is the hex value
+# this is useful for passing strings to javascript through HTML, because
+# javascript's "unescape" function expects strings in this format
+sub ejs_all
+{
+    my $a = $_[0];
+    $a =~ s/(.)/uc sprintf("%%%02x",ord($1))/eg;
+    return $a;
+}
+
+
+# strip all HTML tags from a string
+sub strip_html {
+    my $str = shift;
+    $str =~ s/\<lj user\=['"]?([\w-]+)['"]?\>/$1/g;   # "
+    $str =~ s/\<([^\<])+\>//g;
+    return $str;
+}
+
+# <LJFUNC>
+# name: LJ::is_ascii
+# des: checks if text is pure ASCII.
+# args: text
+# des-text: text to check for being pure 7-bit ASCII text.
+# returns: 1 if text is indeed pure 7-bit, 0 otherwise.
+# </LJFUNC>
+sub is_ascii {
+    my $text = shift;
+    return ($text !~ m/[^\x01-\x7f]/);
+}
+
+# <LJFUNC>
+# name: LJ::is_utf8
+# des: check text for UTF-8 validity.
+# args: text
+# des-text: text to check for UTF-8 validity
+# returns: 1 if text is a valid UTF-8 stream, 0 otherwise.
+# </LJFUNC>
+sub is_utf8 {
+    my $text = shift;
+
+    # it seems there is a dumbass who calls this function
+    # with $text being reference to scalar; now we can tolerate this
+    if (ref ($text) eq "HASH") {
+      return ! (grep { !LJ::is_utf8($_) } values %{$text});
+    }
+    elsif (ref ($text) eq "ARRAY") {
+      return ! (grep { !LJ::is_utf8($_) } @{$text});
+    }
+    elsif (ref ($text)) {
+      return 0;
+    }
+    
+    if (LJ::are_hooks("is_utf8")) {
+        return LJ::run_hook("is_utf8", $text);
+    }
+
+    # for a discussion of the different utf8 validity checking methods,
+    # see:  http://zilla.livejournal.org/657
+    # in summary, this isn't the fastest, but it's pretty fast, it doesn't make
+    # perl segfault, and it doesn't add new crazy dependencies.  if you want
+    # speed, check out ljcom's is_utf8 version in C, using Inline.pm
+
+    return 1 unless defined($text);
+
+    my $u = Unicode::String::utf8($text);
+    my $text2 = $u->utf8;
+
+#    return $text eq $text2;
+
+    return LJ::is_ascii($text) || utf8::is_utf8($text) || $text eq $text2;
+}
+
+# <LJFUNC>
+# name: LJ::text_out
+# des: force outgoing text into valid UTF-8.
+# args: text
+# des-text: reference to text to pass to output. Text if modified in-place.
+# returns: nothing.
+# </LJFUNC>
+sub text_out
+{
+    my $rtext = shift;
+
+    # if we're not Unicode, do nothing
+    return unless $LJ::UNICODE;
+
+    # is this valid UTF-8 already?
+    return if LJ::is_utf8($$rtext);
+
+    # no. Blot out all non-ASCII chars
+    $$rtext =~ s/[\x00\x80-\xff]/\?/g;
+    return;
+}
+
+# <LJFUNC>
+# name: LJ::text_in
+# des: do appropriate checks on input text. Should be called on all
+#      user-generated text.
+# args: text
+# des-text: text to check
+# returns: 1 if the text is valid, 0 if not.
+# </LJFUNC>
+sub text_in
+{
+    my $text = shift;
+    return 1 unless $LJ::UNICODE;
+    if (ref ($text) eq "HASH") {
+        return ! (grep { !LJ::is_utf8($_) } values %{$text});
+    }
+    if (ref ($text) eq "ARRAY") {
+        return ! (grep { !LJ::is_utf8($_) } @{$text});
+    }
+    return LJ::is_utf8($text);
+}
+
+# <LJFUNC>
+# name: LJ::text_convert
+# des: convert old entries/comments to UTF-8 using user's default encoding.
+# args: dbs?, text, u, error
+# des-dbs: optional. Deprecated; a master/slave set of database handles.
+# des-text: old possibly non-ASCII text to convert
+# des-u: user hashref of the journal's owner
+# des-error: ref to a scalar variable which is set to 1 on error
+#            (when user has no default encoding defined, but
+#            text needs to be translated).
+# returns: converted text or undef on error
+# </LJFUNC>
+sub text_convert
+{
+    &nodb;
+    my ($text, $u, $error) = @_;
+
+    # maybe it's pure ASCII?
+    return $text if LJ::is_ascii($text);
+
+    # load encoding id->name mapping if it's not loaded yet
+    LJ::load_codes({ "encoding" => \%LJ::CACHE_ENCODINGS } )
+        unless %LJ::CACHE_ENCODINGS;
+
+    if ($u->{'oldenc'} == 0 ||
+        not defined $LJ::CACHE_ENCODINGS{$u->{'oldenc'}}) {
+        $$error = 1;
+        return undef;
+    };
+
+    # convert!
+    my $name = $LJ::CACHE_ENCODINGS{$u->{'oldenc'}};
+    unless (LJ::ConvUTF8->supported_charset($name)) {
+        $$error = 1;
+        return undef;
+    }
+
+    return LJ::ConvUTF8->to_utf8($name, $text);
+}
+
+
+# <LJFUNC>
+# name: LJ::text_length
+# des: returns both byte length and character length of a string. In a non-Unicode
+#      environment, this means byte length twice. In a Unicode environment,
+#      the function assumes that its argument is a valid UTF-8 string.
+# args: text
+# des-text: the string to measure
+# returns: a list of two values, (byte_length, char_length).
+# </LJFUNC>
+
+sub text_length
+{
+    my $text = shift;
+    my $bl = length($text);
+    unless ($LJ::UNICODE) {
+        return ($bl, $bl);
+    }
+    my $cl = 0;
+    my $utf_char = "([\x00-\x7f]|[\xc0-\xdf].|[\xe0-\xef]..|[\xf0-\xf7]...)";
+
+    while ($text =~ m/$utf_char/go) { $cl++; }
+    return ($bl, $cl);
+}
+
+# <LJFUNC>
+# name: LJ::text_trim
+# des: truncate string according to requirements on byte length, char
+#      length, or both. "char length" means number of UTF-8 characters if
+#      [ljconfig[unicode]] is set, or the same thing as byte length otherwise.
+# args: text, byte_max, char_max
+# des-text: the string to trim
+# des-byte_max: maximum allowed length in bytes; if 0, there's no restriction
+# des-char_max: maximum allowed length in chars; if 0, there's no restriction
+# returns: the truncated string.
+# </LJFUNC>
+sub text_trim
+{
+    my ($text, $byte_max, $char_max) = @_;
+    return $text unless $byte_max or $char_max;
+    if (!$LJ::UNICODE) {
+        $byte_max = $char_max if $char_max and $char_max < $byte_max;
+        $byte_max = $char_max unless $byte_max;
+        return substr($text, 0, $byte_max);
+    }
+
+    # after upgrade to perl 5.12 we can use perl subroutines to handle unicode
+    # (need to convert all the input to unicode as soon as it enters the system)
+    return substr($text,0,$char_max);
+
+#    my $cur = 0;
+#    my $utf_char = "([\x00-\x7f]|[\xc0-\xdf].|[\xe0-\xef]..|[\xf0-\xf7]...)";
+#
+#    # if we don't have a character limit, assume it's the same as the byte limit.
+#    # we will never have more characters than bytes, but we might have more bytes
+#    # than characters, so we can't inherit the other way.
+#    $char_max ||= $byte_max;
+#
+#    while ($text =~ m/$utf_char/gco) {
+#        last unless $char_max;
+#        last if $cur + length($1) > $byte_max and $byte_max;
+#        $cur += length($1);
+#        $char_max--;
+#    }
+#    return substr($text,0,$cur);
+}
+
+# <LJFUNC>
+# name: LJ::text_compress
+# des: Compresses a chunk of text, to gzip, if configured for site.  Can compress
+#      a scalarref in place, or return a compressed copy.  Won't compress if
+#      value is too small, already compressed, or size would grow by compressing.
+# args: text
+# des-text: either a scalar or scalarref
+# returns: nothing if given a scalarref (to compress in-place), or original/compressed value,
+#          depending on site config.
+# </LJFUNC>
+sub text_compress
+{
+    my $text = shift;
+    my $ref = ref $text;
+    return $ref ? undef : $text unless $LJ::COMPRESS_TEXT;
+    die "Invalid reference" if $ref && $ref ne "SCALAR";
+
+    my $tref = $ref ? $text : \$text;
+    my $pre_len = length($$tref);
+    unless (substr($$tref,0,2) eq "\037\213" || $pre_len < 100) {
+        my $gz = Compress::Zlib::memGzip($$tref);
+        if (length($gz) < $pre_len) {
+            $$tref = $gz;
+        }
+    }
+
+    return $ref ? undef : $$tref;
+}
+
+# <LJFUNC>
+# name: LJ::text_uncompress
+# des: Uncompresses a chunk of text, from gzip, if configured for site.  Can uncompress
+#      a scalarref in place, or return a compressed copy.  Won't uncompress unless
+#      it finds the gzip magic number at the beginning of the text.
+# args: text
+# des-text: either a scalar or scalarref.
+# returns: nothing if given a scalarref (to uncompress in-place), or original/uncompressed value,
+#          depending on if test was compressed or not
+# </LJFUNC>
+sub text_uncompress
+{
+    my $text = shift;
+    my $ref = ref $text;
+    die "Invalid reference" if $ref && $ref ne "SCALAR";
+    my $tref = $ref ? $text : \$text;
+
+    # check for gzip's magic number
+    if (substr($$tref,0,2) eq "\037\213") {
+        $$tref = Compress::Zlib::memGunzip($$tref);
+    }
+
+    return $ref ? undef : $$tref;
+}
+
+# function to trim a string containing HTML.  this will auto-close any
+# html tags that were still open when the string was truncated
+sub html_trim {
+    my ($text, $char_max) = @_;
+
+    return $text unless $char_max;
+
+    my $p = HTML::TokeParser->new(\$text);
+    my @open_tags; # keep track of what tags are open
+    my $out = '';
+    my $content_len = 0;
+
+  TOKEN:
+    while (my $token = $p->get_token) {
+        my $type = $token->[0];
+        my $tag  = $token->[1];
+        my $attr = $token->[2];  # hashref
+
+        if ($type eq "S") {
+            my $selfclose;
+
+            # start tag
+            $out .= "<$tag";
+
+            # assume tags are properly self-closed
+            $selfclose = 1 if lc $tag eq 'input' || lc $tag eq 'br' || lc $tag eq 'img';
+
+            # preserve order of attributes. the original order is
+            # in element 4 of $token
+            foreach my $attrname (@{$token->[3]}) {
+                if ($attrname eq '/') {
+                    $selfclose = 1;
+                    next;
+                }
+
+                # FIXME: ultra ghetto.
+                $attr->{$attrname} = LJ::no_utf8_flag($attr->{$attrname});
+                $out .= " $attrname=\"" . LJ::ehtml($attr->{$attrname}) . "\"";
+            }
+
+            $out .= $selfclose ? " />" : ">";
+
+            push @open_tags, $tag unless $selfclose;
+
+        } elsif ($type eq 'T' || $type eq 'D') {
+            my $content = $token->[1];
+
+            if (length($content) + $content_len > $char_max) {
+
+                # truncate and stop parsing
+                $content = LJ::text_trim($content, undef, ($char_max - $content_len));
+                $out .= $content;
+                last;
+            }
+
+            $content_len += length $content;
+
+            $out .= $content;
+
+        } elsif ($type eq 'C') {
+            # comment, don't care
+            $out .= $token->[1];
+
+        } elsif ($type eq 'E') {
+            # end tag
+            pop @open_tags;
+            $out .= "</$tag>";
+        }
+    }
+
+    $out .= join("\n", map { "</$_>" } reverse @open_tags);
+
+    return $out;
+}
+
+# takes a number, inserts commas where needed
+sub commafy {
+    my $number = shift;
+    return $number unless $number =~ /^\d+$/;
+
+    my $punc = LJ::Lang::ml('number.punctuation') || ",";
+    $number =~ s/(?<=\d)(?=(\d\d\d)+(?!\d))/$punc/g;
+    return $number;
+}
+
+# <LJFUNC>
+# name: LJ::html_newlines
+# des: Replace newlines with HTML break tags.
+# args: text
+# returns: text, possibly including HTML break tags.
+# </LJFUNC>
+sub html_newlines
+{
+    my $text = shift;
+    $text =~ s/\n/<br \/>/gm;
+
+    return $text;
+}
+
+# given HTML, returns an arrayref of URLs to images that are in the HTML
+sub html_get_img_urls {
+    my $htmlref = shift;
+    my %opts = @_;
+
+    my $exclude_site_imgs = $opts{exclude_site_imgs} || 0;
+
+    my @image_urls;
+    my $p = HTML::TokeParser->new($htmlref);
+
+    while (my $token = $p->get_token) {
+        if ($token->[1] eq "img") {
+            my $attrs = $token->[2];
+            foreach my $attr (keys %$attrs) {
+                push @image_urls, $attrs->{$attr} if
+                    $attr eq "src" &&
+                    ($exclude_site_imgs ? $attrs->{$attr} !~ /^$LJ::IMGPREFIX/ : 1);
+            }
+        }
+    }
+
+    return \@image_urls;
+}
+
+# given HTML, returns an arrayref of link URLs that are in the HTML
+sub html_get_link_urls {
+    my $htmlref = shift;
+    my %opts = @_;
+
+    my @link_urls;
+    my $p = HTML::TokeParser->new($htmlref);
+
+    while (my $token = $p->get_token) {
+        if ($token->[0] eq "S" && $token->[1] eq "a") {
+            my $attrs = $token->[2];
+            foreach my $attr (keys %$attrs) {
+                push @link_urls, $attrs->{$attr} if $attr eq "href";
+            }
+        }
+    }
+
+    return \@link_urls;
+}
+
+1;

local/cgi-bin/modperl_subs.pl

@@ -0,0 +1,144 @@
+#!/usr/bin/perl
+#
+
+# to be require'd by modperl.pl
+
+use strict;
+
+package LJ;
+
+use Apache;
+use Apache::LiveJournal;
+use Apache::CompressClientFixup;
+use Apache::BML;
+use Apache::SendStats;
+use Apache::DebateSuicide;
+
+use Digest::MD5;
+use MIME::Words;
+use Text::Wrap ();
+use LWP::UserAgent ();
+use Storable;
+use Time::HiRes ();
+use Image::Size ();
+use POSIX ();
+
+use GD::Simple;
+
+use LJ::SpellCheck;
+use LJ::TextMessage;
+use LJ::Blob;
+use LJ::Captcha;
+use LJ::OpenID;
+use MogileFS;
+#use MogileFS qw(+preload);
+use DDLockClient ();
+
+# Try to load GTop library
+BEGIN { $LJ::HAVE_GTOP = eval "use GTop (); 1;" }
+
+# Try to load DBI::Profile
+BEGIN { $LJ::HAVE_DBI_PROFILE = eval "use DBI::Profile (); 1;" }
+
+require "$ENV{'LJHOME'}/cgi-bin/ljlang.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
+require "$ENV{'LJHOME'}/cgi-bin/htmlcontrols.pl";
+require "$ENV{'LJHOME'}/cgi-bin/weblib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/imageconf.pl";
+require "$ENV{'LJHOME'}/cgi-bin/propparse.pl";
+require "$ENV{'LJHOME'}/cgi-bin/supportlib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
+require "$ENV{'LJHOME'}/cgi-bin/portal.pl";
+require "$ENV{'LJHOME'}/cgi-bin/talklib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljtodo.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljfeed.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljlinks.pl";
+require "$ENV{'LJHOME'}/cgi-bin/directorylib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/emailcheck.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljmemories.pl";
+require "$ENV{'LJHOME'}/cgi-bin/ljmail.pl";
+require "$ENV{'LJHOME'}/cgi-bin/sysban.pl";
+require "$ENV{'LJHOME'}/cgi-bin/synlib.pl";
+require "$ENV{'LJHOME'}/cgi-bin/communitylib.pl";
+
+require "taglib.pl";
+
+# preload site-local libraries, if present:
+require "$ENV{'LJHOME'}/cgi-bin/modperl_subs-local.pl"
+    if -e "$ENV{'LJHOME'}/cgi-bin/modperl_subs-local.pl";
+
+$LJ::IMGPREFIX_BAK = $LJ::IMGPREFIX;
+$LJ::STATPREFIX_BAK = $LJ::STATPREFIX;
+
+package LJ::ModPerl;
+
+# pull in a lot of useful stuff before we fork children
+
+sub setup_start {
+
+    # auto-load some stuff before fork:
+    Storable::thaw(Storable::nfreeze({}));
+    foreach my $minifile ("GIF89a", "\x89PNG\x0d\x0a\x1a\x0a", "\xFF\xD8") {
+        Image::Size::imgsize(\$minifile);
+    }
+    DBI->install_driver("mysql");
+    LJ::CleanHTML::helper_preload();
+
+    # set this before we fork
+    $LJ::CACHE_CONFIG_MODTIME = (stat("$ENV{'LJHOME'}/cgi-bin/ljconfig.pl"))[9];
+    
+    my $img = GD::Simple->new(0,0);
+    $img->read_color_table();
+    
+    eval { setup_start_local(); };
+}
+
+sub setup_restart {
+
+    # setup httpd.conf things for the user:
+    Apache->httpd_conf("DocumentRoot $LJ::HTDOCS")
+        if $LJ::HTDOCS;
+    Apache->httpd_conf("ServerAdmin $LJ::ADMIN_EMAIL")
+        if $LJ::ADMIN_EMAIL;
+
+    Apache->httpd_conf(qq{
+
+# This interferes with LJ's /~user URI, depending on the module order
+<IfModule mod_userdir.c>
+  UserDir disabled
+</IfModule>
+
+PerlInitHandler Apache::LiveJournal
+PerlInitHandler Apache::SendStats
+PerlFixupHandler Apache::CompressClientFixup
+PerlCleanupHandler Apache::SendStats
+PerlCleanupHandler Apache::DebateSuicide
+PerlChildInitHandler Apache::SendStats
+DirectoryIndex index.html index.bml
+});
+
+    if ($LJ::BML_DENY_CONFIG) {
+        Apache->httpd_conf("PerlSetVar BML_denyconfig \"$LJ::BML_DENY_CONFIG\"\n");
+    }
+
+    unless ($LJ::SERVER_TOTALLY_DOWN)
+    {
+        Apache->httpd_conf(qq{
+# BML support:
+<Files ~ "\\.bml\$">
+  SetHandler perl-script
+  PerlHandler Apache::BML
+</Files>
+
+# User-friendly error messages
+ErrorDocument 404 /404-error.html
+ErrorDocument 500 /500-error.html
+
+});
+    }
+
+}
+
+setup_start();
+
+1;

local/cgi-bin/parsefeed.pl

@@ -0,0 +1,495 @@
+#!/usr/bin/perl
+
+use strict;
+
+package LJ::ParseFeed;
+
+use XML::RSS;
+use XML::Parser;
+
+
+# parse_feed parses an RSS/Atom feed 
+# arguments: content and, optionally, type, specifying "atom" or
+# "rss". If type isn't supplied, the function will try to guess it
+# based on contents.
+# It returns $feed, which is a hash
+# with the following keys:
+#  type - 'atom' or 'rss'
+#  version - version of the feed in its standard
+#  link - URL of the feed
+#  title - title of the feed
+#  description - description of the feed
+#  # TODO: more kinds of info?
+#
+#  items - arrayref of item hashes, in the same order they were in the feed
+#    each item contains:
+#    link - URL of the item
+#    id - unique identifier (optional)
+#    text - text of the item
+#    subject - subject
+#    time - in format 'yyyy-mm-dd hh:mm' (optional)
+# the second argument returned is $error, which, if defined, is a human-readable
+# error string. the third argument is arrayref of items, same as 
+# $feed->{'items'}.
+
+sub parse_feed
+{
+    my ($content, $type) = @_;
+    my ($feed, $items, $error);
+    my $parser;
+
+    # is it RSS or Atom?
+    # Atom feeds are rare for now, so prefer to err in favor of RSS
+    # simple heuristic: Atom feeds will have '<feed' somewhere at the beginning
+    # TODO: maybe store the feed's type on creation in a userprop and not guess here
+    
+    my $cut = substr($content, 0, 255);
+    if ($type eq 'atom' || $cut =~ m!\<feed!) {
+        # try treating it as an atom feed
+        $parser = new XML::Parser(Style=>'Stream', Pkg=>'LJ::ParseFeed::Atom');
+        return ("", "failed to create XML parser") unless $parser;
+        eval {
+            $parser->parse($content);
+        };
+        if ($@) {
+            $error = "XML parser error: $@";
+        } else {
+            ($feed, $items, $error) = LJ::ParseFeed::Atom::results();
+        };
+    
+        if ($feed || $type eq 'atom') {
+            # there was a top-level <feed> there, or we're forced to treat
+            # as an Atom feed, so even if $error is set,
+            # don't try RSS
+            $feed->{'type'} = 'atom';
+            return ($feed, $error, $items);
+        }
+    }
+
+    # try parsing it as RSS
+    $parser = new XML::RSS;
+    return ("", "failed to create RSS parser") unless $parser;
+    eval {
+        $parser->parse($content);
+    };
+    if ($@) {
+        $error = "RSS parser error: $@";
+        return ("", $error);
+    }
+
+    $feed = {};
+    $feed->{'type'} = 'rss';
+    $feed->{'version'} = $parser->{'version'};
+
+    foreach (qw (link title description lastBuildDate)) {
+        $feed->{$_} = $parser->{'channel'}->{$_}
+            if $parser->{'channel'}->{$_};
+    }
+    
+    if ($parser->{'image'}->{'url'}) {
+        $feed->{'image'} = $parser->{'image'}->{'url'};
+    }
+   
+
+    $feed->{'lastmod'} = undef;
+    $feed->{'items'} = [];
+
+    foreach(@{$parser->{'items'}}) {
+        my $item = {};
+        $item->{'subject'} = $_->{'title'};
+        $item->{'text'} = $_->{'description'};
+        $item->{'link'} = $_->{'link'} if $_->{'link'};
+        $item->{'id'} = $_->{'guid'} if $_->{'guid'};
+
+        my $nsdc = 'http://purl.org/dc/elements/1.1/';
+        my $nsenc = 'http://purl.org/rss/1.0/modules/content/';
+        if ($_->{$nsenc} && ref($_->{$nsenc}) eq "HASH") {
+            # prefer content:encoded if present
+            $item->{'text'} = $_->{$nsenc}->{'encoded'}
+                if defined $_->{$nsenc}->{'encoded'};
+        }
+
+        if ($_->{'pubDate'}) {
+            my $time = time822_to_time($_->{'pubDate'});
+            $item->{'time'} = $time if $time;
+        }
+        if ($_->{$nsdc} && ref($_->{$nsdc}) eq "HASH") {
+            if ($_->{$nsdc}->{date}) {
+                my $time = w3cdtf_to_time($_->{$nsdc}->{date});
+                $item->{'time'} = $time if $time;
+            }
+        }
+        if ($_->{'pubDate'} && (! $feed->{'lastmod'} ||
+            	(LJ::http_to_time($feed->{'lastmod'}) < LJ::http_to_time($_->{'pubDate'})))) {
+            $feed->{'lastmod'} = $_->{'pubDate'};
+        }
+
+        push @{$feed->{'items'}}, $item;
+    }
+
+    return ($feed, undef, $feed->{'items'});
+}
+
+# convert rfc822-time in RSS's <pubDate> to our time
+# see http://www.faqs.org/rfcs/rfc822.html
+# RFC822 specifies 2 digits for year, and RSS2.0 refers to RFC822,
+# but real RSS2.0 feeds apparently use 4 digits. 
+sub time822_to_time {
+    my $t822 = shift;
+    # remove day name if present
+    $t822 =~ s/^\s*\w+\s*,//;
+    # remove whitespace
+    $t822 =~ s/^\s*//;
+    # break it up
+    if ($t822 =~ m!(\d?\d)\s+(\w+)\s+(\d\d\d\d)\s+(\d?\d):(\d\d)!) {
+        my ($day, $mon, $year, $hour, $min) = ($1,$2,$3,$4,$5);
+        $day = "0" . $day if length($day) == 1;
+        $hour = "0" . $hour if length($hour) == 1;
+        $mon = {'Jan'=>'01', 'Feb'=>'02', 'Mar'=>'03', 'Apr'=>'04',
+                'May'=>'05', 'Jun'=>'06', 'Jul'=>'07', 'Aug'=>'08',
+                'Sep'=>'09', 'Oct'=>'10', 'Nov'=>'11', 'Dec'=>'12'}->{$mon};
+        return undef unless $mon;
+        return "$year-$mon-$day $hour:$min";
+    } else {
+        return undef;
+    }
+}
+
+# convert W3C-DTF to our internal format
+# see http://www.w3.org/TR/NOTE-datetime
+# Based very loosely on code from DateTime::Format::W3CDTF,
+# which isn't stable yet so we can't use it directly.
+sub w3cdtf_to_time {
+    my $tw3 = shift;
+
+    # TODO: Should somehow return the timezone offset
+    #   so that it can stored... but we don't do timezones
+    #   yet anyway. For now, just strip the timezone
+    #   portion if it is present, along with the decimal
+    #   fractions of a second.
+    
+    $tw3 =~ s/(?:\.\d+)?(?:[+-]\d{1,2}:\d{1,2}|Z)$//;
+    $tw3 =~ s/^\s*//; $tw3 =~ s/\s*$//; # Eat any superflous whitespace
+
+    # We can only use complete times, so anything which
+    # doesn't feature the time part is considered invalid.
+    
+    # This is working around clients that don't implement W3C-DTF
+    # correctly, and only send single digit values in the dates.
+    # 2004-4-8T16:9:4Z vs 2004-04-08T16:09:44Z
+    # If it's more messed up than that, reject it outright.
+    $tw3 =~ /^(\d{4})-(\d{1,2})-(\d{1,2})T(\d{1,2}):(\d{1,2})(?::(\d{1,2}))?$/
+        or return undef;
+
+    my %pd; # parsed date
+    $pd{Y} = $1; $pd{M} = $2; $pd{D} = $3;
+    $pd{h} = $4; $pd{m} = $5; $pd{s} = $6;
+
+    # force double digits
+    foreach (qw/ M D h m s /) {
+        next unless defined $pd{$_};
+        $pd{$_} = sprintf "%02d", $pd{$_};
+    }
+
+    return $pd{s} ? "$pd{Y}-$pd{M}-$pd{D} $pd{h}:$pd{m}:$pd{s}" :
+                    "$pd{Y}-$pd{M}-$pd{D} $pd{h}:$pd{m}";
+}
+
+package LJ::ParseFeed::Atom;
+
+our ($feed, $item, $data);
+our ($ddepth, $dholder); # for accumulating;
+our @items;
+our $error;
+
+sub err {
+    $error = shift unless $error;
+}
+
+sub results {
+    return ($feed, \@items, $error);
+}
+
+# $name under which we'll store accumulated data may be different
+# from $tag which causes us to store it
+# $name may be a scalarref pointing to where we should store
+# swallowing is achieved by calling startaccum('');
+
+sub startaccum {
+    my $name = shift;
+
+    return err("Tag found under neither <feed> nor <entry>")
+        unless $feed || $item;
+    $data = ""; # defining $data triggers accumulation
+    $ddepth = 1;
+
+    $dholder = undef 
+        unless $name;
+    # if $name is a scalarref, it's actually our $dholder
+    if (ref($name) eq 'SCALAR') {
+        $dholder = $name;
+    } else {
+        $dholder = ($item ? \$item->{$name} : \$feed->{$name})
+            if $name;
+    }
+    return;
+}
+
+sub swallow {
+    return startaccum('');
+}
+
+sub StartDocument {
+    ($feed, $item, $data) = (undef, undef, undef);
+    @items = ();
+    undef $error;
+}
+
+sub StartTag {
+    # $_ carries the unparsed tag
+    my ($p, $tag) = @_;
+    my $holder;
+
+    # do nothing if there has been an error
+    return if $error;
+
+    # are we just accumulating data?
+    if (defined $data) {
+        $data .= $_;
+        $ddepth++;
+        return;
+    }
+
+    # where we'll usually store info
+    $holder = $item ? $item : $feed;
+
+    TAGS: {
+        if ($tag eq 'feed') {
+            return err("Nested <feed> tags") 
+                if $feed;
+            $feed = {};
+            $feed->{'standard'} = 'atom';
+            $feed->{'version'} = $_{'version'};
+#           return err("No version specified in <feed>")
+#                unless $feed->{'version'};
+# commented out as it's done in 
+# http://code.livejournal.org/trac/livejournal/browser/trunk/cgi-bin/parsefeed.pl
+# (too many sites return this error now)
+            return err("Incompatible version specified in <feed>")
+               if $feed->{'version'} && $feed->{'version'} < 0.3;
+            last TAGS;
+        }
+        if ($tag eq 'entry') {
+            return err("Nested <entry> tags") 
+                if $item;
+            $item = {};
+            last TAGS;
+        }
+        
+        # at this point, we must have a top-level <feed> or <entry>
+        # to write into
+        return err("Tag found under neither <feed> nor <entry>")
+            unless $holder;
+
+        if ($tag eq 'link') {
+            # ignore links with rel= anything but alternate
+            unless ($_{'rel'} eq 'alternate') {
+                swallow();
+                last TAGS;
+            }
+            $holder->{'link'} = $_{'href'};
+            return err("No href attribute in <link>")
+                unless $holder->{'link'};
+            last TAGS;
+        }
+
+        if ($tag eq 'content') {
+            return err("<content> outside <entry>")
+                unless $item;
+            # if type is multipart/alternative, we continue recursing
+            # otherwise we accumulate
+            my $type = $_{'type'} || "text/plain";
+            unless ($type eq "multipart/alternative") {
+                push @{$item->{'contents'}}, [$type, ""];
+                startaccum(\$item->{'contents'}->[-1]->[1]);
+                last TAGS;
+            }
+            # it's multipart/alternative, so recurse, but don't swallow
+            last TAGS;
+        }
+
+        # store tags which should require no further
+        # processing as they are, and others under _atom_*, to be processed
+        # in EndTag under </entry>
+        if ($tag eq 'title') {
+            if ($item) { # entry's subject
+                startaccum("subject");
+            } else { # feed's title
+                startaccum($tag);
+            }
+            last TAGS;
+        }
+        if ($tag eq 'id') {
+            unless ($item) {
+                swallow(); # we don't need feed-level <id>
+            } else {
+                startaccum($tag);
+            }
+            last TAGS;
+        }
+
+        if ($tag eq 'tagline' && !$item) { # feed's tagline, our "description"
+            startaccum("description");
+            last TAGS;
+        }
+
+        # accumulate and store
+        startaccum("_atom_" . $tag);
+        last TAGS;
+    }
+            
+    return;
+}
+
+sub EndTag {
+    # $_ carries the unparsed tag
+    my ($p, $tag) = @_;
+
+    # do nothing if there has been an error
+    return if $error;
+
+    # are we accumulating data?
+    if (defined $data) {
+        $ddepth--;
+        if ($ddepth == 0) { # stop accumulating
+            $$dholder = $data
+                if $dholder;
+            undef $data;
+            return;
+        }
+        $data .= $_;
+        return;
+    }
+
+    TAGS: {
+        if ($tag eq 'entry') {
+            # finalize item...
+            # generate suitable text from $item->{'contents'}            
+            my $content;
+            $item->{'contents'} ||= [];
+            unless (scalar(@{$item->{'contents'}}) >= 1) {
+                # this item had no <content>
+                # maybe it has <summary>? if so, use <summary>
+                # TODO: type= or encoding issues here? perhaps unite
+                # handling of <summary> with that of <content>?
+                if ($item->{'_atom_summary'}) {
+                    $item->{'text'} = $item->{'_atom_summary'};
+                    delete $item->{'contents'};
+                } else {
+                    # nothing to display, so ignore this entry
+                    undef $item;
+                    last TAGS;
+                }
+            }
+
+            unless ($item->{'text'}) { # unless we already have text
+                if (scalar(@{$item->{'contents'}}) == 1) {
+                    # only one <content> section
+                    $content = $item->{'contents'}->[0]; 
+                } else {
+                    # several <content> section, must choose the best one
+                    foreach (@{$item->{'contents'}}) {
+                        if ($_->[0] eq "application/xhtml+xml") { # best match
+                            $content = $_;
+                            last; # don't bother to look at others
+                        }
+                        if ($_->[0] =~ m!html!) { # some kind of html/xhtml/html+xml, etc.
+                            # choose this unless we've already chosen some html
+                            $content = $_
+                                unless $content->[0] =~ m!html!;
+                            next;
+                        }
+                        if ($_->[0] eq "text/plain") {
+                            # choose this unless we have some html already
+                            $content = $_
+                                unless $content->[0] =~ m!html!;
+                            next;
+                        }
+                    }
+                    # if we didn't choose anything, pick the first one
+                    $content =  $item->{'contents'}->[0]
+                        unless $content;
+                }
+
+                # we ignore the 'mode' attribute of <content>. If it's "xml", we've
+                # stringified it by accumulation; if it's "escaped", our parser
+                # unescaped it
+                # TODO: handle mode=base64?
+
+                $item->{'text'} = $content->[1];
+                delete $item->{'contents'};
+            }
+
+            # generate time
+            my $w3time = $item->{'_atom_modified'} || $item->{'_atom_created'};
+            my $time;
+            if ($w3time) {
+                # see http://www.w3.org/TR/NOTE-datetime for format
+                # we insist on having granularity up to a minute,
+                # and ignore finer data as well as the timezone, for now
+                if ($w3time =~ m!^(\d\d\d\d)-(\d\d)-(\d\d)T(\d\d):(\d\d)!) {
+                    $time = "$1-$2-$3 $4:$5";
+                }
+            }
+            if ($time) {
+                $item->{'time'} = $time;
+            }
+            
+            # get rid of all other tags we don't need anymore
+            foreach (keys  %$item) {
+                delete $item->{$_} if substr($_, 0, 6) eq '_atom_';
+            }
+            
+            push @items, $item;
+            undef $item;
+            last TAGS;
+        }
+        if ($tag eq 'feed') {
+            # finalize feed
+            # get rid of all other tags we don't need anymore
+            foreach (keys  %$feed) {
+                delete $feed->{$_} if substr($_, 0, 6) eq '_atom_';
+            }
+            
+            # link the feed with its itms
+            $feed->{'items'} = \@items 
+                if $feed;
+            last TAGS;
+        }
+    }
+    return;
+}
+
+sub Text {
+    my $p = shift;
+
+    # do nothing if there has been an error
+    return if $error;
+
+    $data .= $_ if defined $data;
+}
+
+sub PI {
+    # ignore processing instructions
+    return;
+}
+
+sub EndDocument {
+    # if we parsed a feed, link items to it
+    $feed->{'items'} = \@items 
+        if $feed;
+    return;
+}
+
+
+1;

local/cgi-bin/phonepost.pl

@@ -0,0 +1,321 @@
+#!/usr/bin/perl
+# vim: set ts=4 sw=4 et :
+
+# some variable names:
+#  - phonepostid, bid, blobid:  all refer to a blob id.
+#  - dppid:  display phonepost id; comparable to a ditemid, but for a phone post.
+
+use strict;
+
+use lib "$ENV{'LJHOME'}/cgi-bin";
+use LJ::Blob;
+
+package LJ::PhonePost;
+
+my $datatypes = {
+    0 => { ext => 'mp3', mime => 'audio/mp3' },
+    1 => { ext => 'ogg', mime => 'application/ogg' },
+    2 => { ext => 'wav', mime => 'audio/wav' },
+};
+
+sub may_transcribe {
+    my ($u, $remote) = @_;
+    return 0 if $remote && $remote->{journaltype} ne 'P';
+    return 1 if $remote && $remote->{userid} == $u->{userid};
+    LJ::load_user_props($u, 'pp_transallow');
+    return 0 if $u->{pp_transallow} == -1;
+    my $groupmask = LJ::get_groupmask($u, $remote);
+    return 1 if ! $u->{pp_transallow} && $groupmask;
+    return ($groupmask & (1 << $u->{pp_transallow})) ? 1 : 0;
+}
+
+sub get_phonepost_entry {
+    my ($u, $bid) = @_;
+    my ($ppe, $memkey);
+
+    $memkey = [$u->{userid}, "ppe:$u->{userid}:$bid"];
+    $ppe = LJ::MemCache::get($memkey);
+
+    return $ppe if $ppe;
+
+    my $dbcr = LJ::get_cluster_def_reader($u);
+    $ppe = $dbcr->selectrow_hashref(qq{
+            SELECT ppe.jitemid, ppe.posttime, ppe.anum, 
+                   ppe.filetype, ub.length, ppe.lengthsecs, ppe.location
+            FROM   phonepostentry ppe, userblob ub
+            WHERE  ub.journalid=? AND ppe.userid=ub.journalid
+            AND    ub.domain=? AND ub.blobid=? AND ppe.blobid=ub.blobid
+            }, undef, $u->{'userid'}, LJ::get_blob_domainid("phonepost"), $bid);
+    LJ::MemCache::set($memkey, $ppe || 0);
+    return $ppe;
+}
+
+sub apache_content {
+    my ($r, $u, $dppid) = @_;
+    my $bid = $dppid >> 8;
+    my $ppe = get_phonepost_entry($u, $bid);
+    return 404 unless $ppe && $ppe->{jitemid} && $ppe->{anum} == $dppid % 256;
+
+    # check security of item
+    my $logrow = LJ::get_log2_row($u, $ppe->{jitemid});
+    return 404 unless $logrow;
+
+    if ($u->{statusvis} eq 'S' || $logrow->{security} ne "public") {
+        # get the remote, ignoring IP, since the request is coming
+        # from Akamai/Speedera/etc and the IP won't match
+        my $remote = LJ::get_remote({ ignore_ip => 1 });
+
+        my %GET = $r->args;
+
+        my $viewall = 0;
+        my $viewsome = 0;
+        if ($remote && $GET{viewall} && LJ::check_priv($remote, "canview")) {
+            LJ::statushistory_add($u->{'userid'}, $remote->{'userid'}, 
+                                  "viewall", "phonepost: $u->{user}, itemid: $ppe->{jitemid}, statusvis: $u->{'statusvis'}");
+
+            $viewall = LJ::check_priv($remote, 'canview', '*');
+            $viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
+        }
+
+        unless ($viewall || $viewsome && $logrow->{security} eq 'public') {
+            return 403 unless LJ::can_view($remote, $logrow);
+        }
+    }
+
+    # future:  if length is NULL, then it's an external reference and we redirect
+    $r->header_out("Cache-Control", "must-revalidate, private");
+    $r->header_out("Content-Length", $ppe->{length});
+    $r->content_type( $datatypes->{ $ppe->{filetype} }->{mime} );
+
+    # handle IMS requests
+    my $last_mod = LJ::time_to_http($ppe->{posttime});
+    if (my $ims = $r->header_in("If-Modified-Since")) {
+        return 304 if $ims eq $last_mod;
+    }
+
+    $r->header_out("Last-Modified", $last_mod);
+    if ($r->header_only) {
+        $r->send_http_header();
+        return 200;
+    }
+
+    my $buffer;
+    if ($ppe->{location} eq 'mogile') {
+        # Mogile
+        if ( !$LJ::REPROXY_DISABLE{phoneposts} &&
+             $r->header_in('X-Proxy-Capabilities') &&
+             $r->header_in('X-Proxy-Capabilities') =~ /\breproxy-file\b/i )
+        {
+            my @paths = LJ::mogclient()->get_paths( "pp:$u->{userid}:$bid", 1 );
+
+            # reproxy url
+            if ($paths[0] =~ m/^http:/) {
+                $r->header_out('X-REPROXY-URL', join(' ', @paths));
+            }
+            # reproxy file
+            else {
+                $r->header_out('X-REPROXY-FILE', $paths[0]);
+            }
+            $r->send_http_header();
+        }
+        else {
+            $buffer = LJ::mogclient()->get_file_data("pp:$u->{userid}:$bid");
+            $r->send_http_header();
+            return 500 unless $buffer && ref $buffer;
+            $r->print($$buffer);
+        }
+
+    }
+    else {
+        # BlobServer
+        $r->send_http_header();
+        my $ret = LJ::Blob::get_stream($u, 'phonepost',
+                                       $datatypes->{ $ppe->{filetype} }->{ext}, $bid, sub {
+            $buffer .= $_[0];
+            if (length($buffer) > 50_000) {
+                $r->print($buffer);
+                undef $buffer;
+            }
+        });
+        $r->print($buffer) if length($buffer);
+        return 500 unless $ret;
+    }
+
+    return 200;
+}
+
+# if $u_embed and $ditemid are given, they represent an entry
+# in which a phonepost tag has been embedded.
+
+sub make_link {
+    my ($remote, $uuid, $phonepostid, $mode, $u_embed, $ditemid) = @_;
+    $phonepostid += 0;
+
+    # mode can either be 'notrans', 'bare', or 'rss'
+    $mode = "notrans" if $mode && $mode !~ /bare|rss/;
+
+    my $u = ref $uuid ? $uuid : LJ::load_userid($uuid);
+    return $mode eq 'rss' ? "" : "<b>[Invalid user]</b>" unless $u;
+    my $userid = $u->{'userid'};
+
+    my $ppe = get_phonepost_entry($u, $phonepostid);
+    return $mode eq 'rss' ? "" : "<b>[Invalid audio link]</b>" unless $ppe;
+
+    if ($u_embed && $ditemid) {
+        # have to check whether the link is embeddable in this entry
+        if ($u_embed->{'userid'} == $userid && 
+            $ditemid>>8 == $ppe->{'jitemid'}) {
+
+            # it's the original entry, we're ok
+        } else {
+            my $accdenied = "<b>[Access to audio link denied]</b>";
+
+            # log2 row in which the tag is embedded
+            my $row = LJ::get_log2_row($u_embed, $ditemid >> 8);
+
+            # the original log2 row of this tag
+            my $row_orig = LJ::get_log2_row($u, $ppe->{'jitemid'});
+            return $mode eq 'rss' ? "" : $accdenied unless $row && $row_orig;
+
+            if ($row_orig->{'security'} eq "public" && 
+                $row->{'posterid'} == $userid &&
+                $u_embed->{'userid'} != $userid) {
+
+                # it's public and moved by the same 
+                # user to a different journal, we're okay
+            } else {
+                return $mode eq 'rss' ? "" : $accdenied;
+            }
+        }
+    }
+
+    my $link;
+    my $dppid = ($phonepostid << 8) + $ppe->{anum};
+    my $ext = $datatypes->{ $ppe->{filetype} }->{ext};
+    my $path = LJ::run_hook("url_phonepost", $u, $dppid, $ext) || 
+        LJ::journal_base($u) . "/data/phonepost/$dppid.$ext";
+
+    # make link and just return that if in bare mode
+    $link = $ppe->{location} eq 'none' ?
+        "<img src='$LJ::IMGPREFIX/phonepost2.gif' alt='' width='35' height='33' />" :
+        "<a href='$path'><img src='$LJ::IMGPREFIX/phonepost2.gif' alt='' " .
+        "width='35' height='33' border='0' /></a>";
+    return $link if $mode eq 'bare';
+
+    my $K = $ppe->{length} ? int($ppe->{length} / 1024) . "K" : "";
+    my $secs = $ppe->{lengthsecs};
+    my $duration = $secs ? sprintf("%d:%02d", int($secs/60), $secs%60) : "";
+
+    # support rss 'enclosures' - podcasting.
+    if ($mode eq 'rss') {
+        $link = "<enclosure url=\"$path\" length=\"$ppe->{length}\" " .
+                "type=\"$datatypes->{ $ppe->{filetype} }->{mime}\" />";
+        return $link;
+    }
+
+    # return full table
+    my $ret = "<table cellspacing='5' cellpadding='0' border='0' class='ljphonepost'><tr>";
+    $ret .= "<td valign='top'>$link</td>";
+    $ret .= "<td valign='top'><strong>";
+    $ret .= $ppe->{location} eq 'none' ? "PhonePost" : "<a href='$path'>PhonePost</a>";
+    $ret .= "</strong><br /><em>$K</em>&nbsp;$duration</td>";
+
+    unless ($mode eq 'notrans') {
+        my $trans_url = "$LJ::SITEROOT/phonepost/transcribe.bml?user=$u->{user}&amp;ppid=$dppid";
+        $ret .= "<td valign='top'><a href='$LJ::SITEROOT/phonepost/about.bml'><img src='$LJ::IMGPREFIX/help.gif' width='14' height='14' border='0' alt='(Help)' /></a></td>";
+        my $trans = LJ::PhonePost::get_latest_trans($u, $phonepostid);
+        if ($trans) {
+        my $by;
+        if ($trans->{revid} == 1) {
+            $by = LJ::ljuser(LJ::get_username($trans->{posterid}));
+        } else {
+            # multiple users transcribing, or just multiple transcriptions of one user?
+            my $memkey = [$u->{userid},"ppetu:$u->{userid}:$phonepostid"];
+            my $tu = LJ::MemCache::get($memkey);
+            unless (defined $tu) {
+                my $dbr = LJ::get_cluster_reader($u);
+                $tu = $dbr->selectrow_array("SELECT COUNT(DISTINCT(posterid)) " .
+                                            "FROM phoneposttrans " .
+                                            "WHERE journalid=? AND blobid=?",
+                                            undef, $u->{'userid'}, $phonepostid + 0);
+                LJ::MemCache::set($memkey, $tu);
+            }
+            $by = ($tu == 1) ? LJ::ljuser(LJ::get_username($trans->{posterid})) : "multiple users";
+        }
+            my $text = LJ::ehtml($trans->{body});
+            $text =~ s/\n/<br \/>/g;
+
+            $ret .= "<td valign='top'><blockquote cite='$path'>&ldquo;$text&rdquo;</blockquote><br />".
+                "<a href='$trans_url'>Transcribed</a> by: $by</td>";
+        } elsif (LJ::PhonePost::may_transcribe($u, $remote)) {
+            $ret .= "<td valign='top'>(<a href='$trans_url'>transcribe</a>)</td>";
+        } else {
+            $ret .= "<td valign='top'>(no transcription available)</td>";
+        }
+    }
+
+    $ret .= "</tr></table>";
+    return $ret;
+
+}
+
+sub get_latest_trans {
+    my ($u, $id) = @_;
+    $id += 0;
+
+    my $memkey = [$u->{userid},"ppelt:$u->{userid}:$id"];
+    my $lt = LJ::MemCache::get($memkey);
+    unless (defined $lt) {
+        my $dbcr = LJ::get_cluster_def_reader($u);
+        return undef unless $dbcr;
+
+        $lt = "";
+        my $latest = $dbcr->selectrow_array("SELECT MAX(revid) FROM phoneposttrans ".
+                "WHERE journalid=? AND blobid=?", undef,
+                $u->{userid}, $id);
+        if ($latest) {
+            $lt = $dbcr->selectrow_hashref("SELECT revid,posterid,posttime,subject,body ".
+                    "FROM phoneposttrans WHERE journalid=? ".
+                    "AND blobid=? AND revid=?", undef,
+                    $u->{userid}, $id, $latest);
+        }
+        LJ::MemCache::set($memkey, $lt);
+    }
+    return $lt;
+}
+
+sub show_phoneposts {
+    my ($u_embed, $ditemid, $remote, $eventref) = @_;
+
+    my $replace = sub {
+        my $tag = shift;
+        my ($user, $userid, $uobj, $phid, $blobid, $dpid);
+
+        # old tag <lj-phonepost user='foo' phonepostid='1' />
+        # new tag <lj-phonepost journalid='1234567' dpid='10000422' />
+        if ($tag =~ m!^journalid=['"](\d+)['"]\s*dpid=['"](\d+)['"]\s*/?$!) {
+            ($userid, $dpid)=($1,$2);
+
+            # prefer phonepostid and userid
+            $phid = $dpid >> 8 if $dpid;
+
+        } elsif ($tag =~ m!^(user=['"](\S+)['"])?\s*(phonepostid=['"](\d+)['"])?\s*(userid=['"](\d+)['"])?\s*(blobid=['"](\d+)['"])?\s*/?$!) {
+            ($user,$phid,$userid,$blobid)=($2,$4,$6,$8);
+
+            # prefer phonepostid and userid
+            $phid = $blobid >> 8
+                unless $phid or not $blobid;
+            do {
+                $uobj = LJ::load_user($user);
+                $userid = $uobj->{'userid'};
+            } unless $userid or $user eq "";
+        }
+
+        return "<b>[Invalid audio link]</b>" unless $phid and $userid;
+
+        return make_link($remote, $userid, $phid, 0, $u_embed, $ditemid);
+    };
+    $$eventref =~ s!<lj-phonepost\s*([^>]*)>!$replace->($1)!eg;
+}
+
+1;