![[site community profile]](https://www.dreamwidth.org/img/comm_staff.png){kind=small}
[dw-free] Remove miscperl dependency by moving it local
[commit: http://hg.dwscoalition.org/dw-free/rev/7ed5651ee848]
Remove miscperl dependency by moving it local
Patch by![[staff profile]](https://www.dreamwidth.org/img/silk/identity/user_staff.png)
mark.
Files modified:
Remove miscperl dependency by moving it local
Patch by
mark.Files modified:
- cgi-bin/DBI/Role.pm
- cgi-bin/HTMLCleaner.pm
- cgi-bin/S2/Color.pm
- cvs/multicvs.conf
--------------------------------------------------------------------------------
diff -r 2a10b7c4ccd1 -r 7ed5651ee848 cgi-bin/DBI/Role.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DBI/Role.pm Tue May 01 06:32:50 2012 +0000
@@ -0,0 +1,441 @@
+#
+# This code was forked from the LiveJournal project owned and operated
+# by Live Journal, Inc. The code has been modified and expanded by
+# Dreamwidth Studios, LLC. These files were originally licensed under
+# the terms of the license supplied by Live Journal, Inc, which can
+# currently be found at:
+#
+# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
+#
+# In accordance with the original license, this code and all its
+# modifications are provided under the GNU General Public License.
+# A copy of that license can be found in the LICENSE file included as
+# part of this distribution.
+#
+
+package DBI::Role;
+
+use 5.006;
+use strict;
+use warnings;
+BEGIN {
+ $DBI::Role::HAVE_HIRES = eval "use Time::HiRes (); 1;";
+}
+
+our $VERSION = '1.00';
+
+# $self contains:
+#
+# DBINFO --- hashref. keys = scalar roles, one of which must be 'master'.
+# values contain DSN info, and 'role' => { 'role' => weight, 'role2' => weight }
+#
+# DEFAULT_DB -- scalar string. default db name if none in DSN hashref in DBINFO
+#
+# DBREQCACHE -- cleared by clear_req_cache() on each request.
+# fdsn -> dbh
+#
+# DBCACHE -- role -> fdsn, or
+# fdsn -> dbh
+#
+# DBCACHE_UNTIL -- role -> unixtime
+#
+# DB_USED_AT -- fdsn -> unixtime
+#
+# DB_DEAD_UNTIL -- fdsn -> unixtime
+#
+# TIME_CHECK -- if true, time between localhost and db are checked every TIME_CHECK
+# seconds
+#
+# TIME_REPORT -- coderef to pass dsn and dbtime to after a TIME_CHECK occurence
+#
+
+sub new
+{
+ my ($class, $args) = @_;
+ my $self = {};
+ $self->{'DBINFO'} = $args->{'sources'};
+ $self->{'TIMEOUT'} = $args->{'timeout'};
+ $self->{'DEFAULT_DB'} = $args->{'default_db'};
+ $self->{'TIME_CHECK'} = $args->{'time_check'};
+ $self->{'TIME_LASTCHECK'} = {}; # dsn -> last check time
+ $self->{'TIME_REPORT'} = $args->{'time_report'};
+ bless $self, ref $class || $class;
+ return $self;
+}
+
+sub set_sources
+{
+ my ($self, $newval) = @_;
+ $self->{'DBINFO'} = $newval;
+ $self;
+}
+
+sub clear_req_cache
+{
+ my $self = shift;
+ $self->{'DBREQCACHE'} = {};
+}
+
+sub disconnect_all
+{
+ my ($self, $opts) = @_;
+ my %except;
+
+ if ($opts && $opts->{except} &&
+ ref $opts->{except} eq 'ARRAY') {
+ $except{$_} = 1 foreach @{$opts->{except}};
+ }
+
+ foreach my $cache (qw(DBREQCACHE DBCACHE)) {
+ next unless ref $self->{$cache} eq "HASH";
+ foreach my $key (keys %{$self->{$cache}}) {
+ next if $except{$key};
+ my $v = $self->{$cache}->{$key};
+ next unless ref $v eq "DBI::db";
+ $v->disconnect;
+ delete $self->{$cache}->{$key};
+ }
+ }
+ $self->{'DBCACHE'} = {};
+ $self->{'DBREQCACHE'} = {};
+}
+
+sub same_cached_handle
+{
+ my $self = shift;
+ my ($role_a, $role_b) = @_;
+ return
+ defined $self->{'DBCACHE'}->{$role_a} &&
+ defined $self->{'DBCACHE'}->{$role_b} &&
+ $self->{'DBCACHE'}->{$role_a} eq $self->{'DBCACHE'}->{$role_b};
+}
+
+sub flush_cache
+{
+ my $self = shift;
+ foreach (keys %{$self->{'DBCACHE'}}) {
+ my $v = $self->{'DBCACHE'}->{$_};
+ next unless ref $v;
+ $v->disconnect;
+ }
+ $self->{'DBCACHE'} = {};
+ $self->{'DBREQCACHE'} = {};
+}
+
+# old interface. does nothing now.
+sub trigger_weight_reload
+{
+ my $self = shift;
+ return $self;
+}
+
+sub use_diff_db
+{
+ my $self = shift;
+ my ($role1, $role2) = @_;
+
+ return 0 if $role1 eq $role2;
+
+ # this is implied: (makes logic below more readable by forcing it)
+ $self->{'DBINFO'}->{'master'}->{'role'}->{'master'} = 1;
+
+ foreach (keys %{$self->{'DBINFO'}}) {
+ next if /^_/;
+ next unless ref $self->{'DBINFO'}->{$_} eq "HASH";
+ if ($self->{'DBINFO'}->{$_}->{'role'}->{$role1} &&
+ $self->{'DBINFO'}->{$_}->{'role'}->{$role2}) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+sub get_dbh
+{
+ my $self = shift;
+ my $opts = ref $_[0] eq "HASH" ? shift : {};
+
+ my @roles = @_;
+ my $role = shift @roles;
+ return undef unless $role;
+
+ my $now = time();
+
+ # if 'nocache' flag is passed, clear caches now so we won't return
+ # a cached database handle later
+ $self->clear_req_cache if $opts->{'nocache'};
+
+ # otherwise, see if we have a role -> full DSN mapping already
+ my ($fdsn, $dbh);
+ if ($role eq "master") {
+ $fdsn = make_dbh_fdsn($self, $self->{'DBINFO'}->{'master'});
+ } else {
+ if ($self->{'DBCACHE'}->{$role} && ! $opts->{'unshared'}) {
+ $fdsn = $self->{'DBCACHE'}->{$role};
+ if ($now > $self->{'DBCACHE_UNTIL'}->{$role}) {
+ # this role -> DSN mapping is too old. invalidate,
+ # and while we're at it, clean up any connections we have
+ # that are too idle.
+ undef $fdsn;
+
+ foreach (keys %{$self->{'DB_USED_AT'}}) {
+ next if $self->{'DB_USED_AT'}->{$_} > $now - 60;
+ delete $self->{'DB_USED_AT'}->{$_};
+ delete $self->{'DBCACHE'}->{$_};
+ }
+ }
+ }
+ }
+
+ if ($fdsn) {
+ $dbh = $self->get_dbh_conn( $opts, $fdsn, $role );
+ return $dbh if $dbh;
+ delete $self->{'DBCACHE'}->{$role}; # guess it was bogus
+ }
+ return undef if $role eq "master"; # no hope now
+
+ # time to randomly weightedly select one.
+ my @applicable;
+ my $total_weight;
+ foreach (keys %{$self->{'DBINFO'}}) {
+ next if /^_/;
+ next unless ref $self->{'DBINFO'}->{$_} eq "HASH";
+ my $weight = $self->{'DBINFO'}->{$_}->{'role'}->{$role};
+ next unless $weight;
+ push @applicable, [ $self->{'DBINFO'}->{$_}, $weight ];
+ $total_weight += $weight;
+ }
+
+ while (@applicable) {
+ my $rand = rand($total_weight);
+ my ($i, $t) = (0, 0);
+ for (; $i<@applicable; $i++) {
+ $t += $applicable[$i]->[1];
+ last if $t > $rand;
+ }
+ my $fdsn = make_dbh_fdsn($self, $applicable[$i]->[0]);
+ $dbh = $self->get_dbh_conn( $opts, $fdsn );
+ if ($dbh) {
+ $self->{'DBCACHE'}->{$role} = $fdsn;
+ $self->{'DBCACHE_UNTIL'}->{$role} = $now + 5 + int(rand(10));
+ return $dbh;
+ }
+
+ # otherwise, discard that one.
+ $total_weight -= $applicable[$i]->[1];
+ splice(@applicable, $i, 1);
+ }
+
+ # try others
+ return get_dbh($self, $opts, @roles);
+}
+
+sub make_dbh_fdsn
+{
+ my $self = shift;
+ my $db = shift; # hashref with DSN info
+ return $db->{'_fdsn'} if $db->{'_fdsn'}; # already made?
+
+ my $fdsn = "DBI:mysql"; # join("|",$dsn,$user,$pass) (because no refs as hash keys)
+ $db->{'dbname'} ||= $self->{'DEFAULT_DB'} if $self->{'DEFAULT_DB'};
+ $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'}";
+
+ $db->{'_fdsn'} = $fdsn;
+ return $fdsn;
+}
+
+sub get_dbh_conn
+{
+ my $self = shift;
+ my $opts = ref $_[0] eq "HASH" ? shift : {};
+ my $fdsn = shift;
+ my $role = shift; # optional.
+ my $now = time();
+
+ my $retdb = sub {
+ my $db = shift;
+ $self->{'DBREQCACHE'}->{$fdsn} = $db;
+ $self->{'DB_USED_AT'}->{$fdsn} = $now;
+ return $db;
+ };
+
+ # have we already created or verified a handle this request for this DSN?
+ return $retdb->($self->{'DBREQCACHE'}->{$fdsn})
+ if $self->{'DBREQCACHE'}->{$fdsn} && ! $opts->{'unshared'};
+
+ # check to see if we recently tried to connect to that dead server
+ return undef if $self->{'DB_DEAD_UNTIL'}->{$fdsn} && $now < $self->{'DB_DEAD_UNTIL'}->{$fdsn};
+
+ # if not, we'll try to find one we used sometime in this process lifetime
+ my $dbh = $self->{'DBCACHE'}->{$fdsn};
+
+ # if it exists, verify it's still alive and return it. (but not
+ # if we're wanting an unshared connection)
+ if ($dbh && ! $opts->{'unshared'}) {
+ return $retdb->($dbh) unless connection_bad($dbh, $opts);
+ undef $dbh;
+ undef $self->{'DBCACHE'}->{$fdsn};
+ }
+
+ # time to make one!
+ my ($dsn, $user, $pass) = split(/\|/, $fdsn);
+ my $timeout = $self->{'TIMEOUT'} || 2;
+ if (ref $timeout eq "CODE") {
+ $timeout = $timeout->($dsn, $user, $pass, $role);
+ }
+ $dsn .= ";mysql_connect_timeout=$timeout" if $timeout;
+
+ my $loop = 1;
+ my $tries = $DBI::Role::HAVE_HIRES ? 8 : 2;
+ while ($loop) {
+ $loop = 0;
+
+ my $connection_opts;
+ if ( $opts->{'connection_opts'} ) {
+ $connection_opts = $opts->{'connection_opts'};
+ } else {
+ $connection_opts = {
+ PrintError => 0,
+ AutoCommit => 1,
+ };
+ }
+
+ $dbh = DBI->connect( $dsn, $user, $pass, $connection_opts );
+
+ $dbh->{private_role} = $role if $dbh;
+
+ # if max connections, try again shortly.
+ if (! $dbh && $DBI::err == 1040 && $tries) {
+ $tries--;
+ $loop = 1;
+ if ($DBI::Role::HAVE_HIRES) {
+ Time::HiRes::usleep(250_000);
+ } else {
+ sleep 1;
+ }
+ next;
+ }
+
+ # if lost connection to server (had prior connection?) error
+ # (MySQL server has gone away)
+ if (! $dbh && $DBI::err == 2013 && $tries) {
+ $tries--;
+ $loop = 1;
+ next;
+ }
+ }
+
+ my $DBI_err = $DBI::err || 0;
+ if ($DBI_err && $DBI::Role::VERBOSE) {
+ $role ||= "";
+ my $str = $DBI::errstr || "(no DBI::errstr)";
+ print STDERR "DBI::Role connect error $DBI_err for role '$role': dsn='$dsn', user='$user': $str\n";
+ }
+
+
+ # check replication/busy processes... see if we should not use
+ # this one
+ undef $dbh if connection_bad($dbh, $opts);
+ # mark server as dead if dead. won't try to reconnect again for 5 seconds.
+ if ($dbh) {
+ # default wait_timeout is 60 seconds.
+ $dbh->do("SET SESSION wait_timeout = 600");
+
+ # if this is an unshared connection, we don't want to put it
+ # in the cache for somebody else to use later. (which happens below)
+ return $dbh if $opts->{'unshared'};
+
+ $self->{'DB_USED_AT'}->{$fdsn} = $now;
+ if ($self->{'TIME_CHECK'} && ref $self->{'TIME_REPORT'} eq "CODE") {
+ my $now = time();
+ $self->{'TIME_LASTCHECK'}->{$dsn} ||= 0; # avoid warnings
+ if ($self->{'TIME_LASTCHECK'}->{$dsn} < $now - $self->{'TIME_CHECK'}) {
+ $self->{'TIME_LASTCHECK'}->{$dsn} = $now;
+ my $db_time = $dbh->selectrow_array("SELECT UNIX_TIMESTAMP()");
+ $self->{'TIME_REPORT'}->($dsn, $db_time, $now);
+ }
+ }
+ } else {
+ # mark the database as dead for a bit, unless it was just because of max connections
+ $self->{'DB_DEAD_UNTIL'}->{$fdsn} = $now + 5
+ unless $DBI_err == 1040 || $DBI_err == 2013;
+
+ }
+
+ return $self->{'DBREQCACHE'}->{$fdsn} = $self->{'DBCACHE'}->{$fdsn} = $dbh;
+}
+
+sub connection_bad {
+ my ($dbh, $opts) = @_;
+
+ return 1 unless $dbh;
+
+ my $ss = eval {
+ $dbh->selectrow_hashref("SHOW SLAVE STATUS");
+ };
+
+ # if there was an error, and it wasn't a permission problem (1227)
+ # then treat this connection as bogus
+ if ($dbh->err && $dbh->err != 1227) {
+ return 1;
+ }
+
+ # connection is good if $ss is undef (not a slave)
+ return 0 unless $ss;
+
+ # otherwise, it's okay if not MySQL 4
+ return 0 if ! $ss->{'Master_Log_File'} || ! $ss->{'Relay_Master_Log_File'};
+
+ # all good if within 100 k
+ if ($opts->{'max_repl_lag'}) {
+ # MySQL 4.0 uses Exec_master_log_pos, 5.0 uses Exec_Master_Log_Pos
+ my $emlp = $ss->{'Exec_master_log_pos'} || $ss->{'Exec_Master_Log_Pos'} || undef;
+ return 0 if
+ $ss->{'Master_Log_File'} eq $ss->{'Relay_Master_Log_File'} &&
+ ($ss->{'Read_Master_Log_Pos'} - $emlp) < $opts->{'max_repl_lag'};
+
+
+ # guess we're behind
+ return 1;
+ } else {
+ # default to assuming it's good
+ return 0;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Role - Get DBI cached handles by role, with weighting & failover.
+
+=head1 SYNOPSIS
+
+ use DBI::Role;
+ my $DBIRole = new DBI::Role {
+ 'sources' => \%DBINFO,
+ 'default_db' => "somedbname", # opt.
+ };
+ my $dbh = $DBIRole->get_dbh("master");
+
+=head1 DESCRIPTION
+
+To be written.
+
+=head2 EXPORT
+
+None by default.
+
+=head1 AUTHOR
+
+Brad Fitzparick, E<lt>brad@danga.comE<gt>
+
+=head1 SEE ALSO
+
+L<DBI>.
+
diff -r 2a10b7c4ccd1 -r 7ed5651ee848 cgi-bin/HTMLCleaner.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/HTMLCleaner.pm Tue May 01 06:32:50 2012 +0000
@@ -0,0 +1,228 @@
+#!/usr/bin/perl
+#
+# This code was forked from the LiveJournal project owned and operated
+# by Live Journal, Inc. The code has been modified and expanded by
+# Dreamwidth Studios, LLC. These files were originally licensed under
+# the terms of the license supplied by Live Journal, Inc, which can
+# currently be found at:
+#
+# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
+#
+# In accordance with the original license, this code and all its
+# modifications are provided under the GNU General Public License.
+# A copy of that license can be found in the LICENSE file included as
+# part of this distribution.
+#
+
+package HTMLCleaner;
+
+use strict;
+use base 'HTML::Parser';
+use CSS::Cleaner;
+
+sub new {
+ my ($class, %opts) = @_;
+
+ my $p = new HTML::Parser(
+ 'api_version' => 3,
+ 'start_h' => [ \&start, 'self, tagname, attr, attrseq, text' ],
+ 'end_h' => [ \&end, 'self, tagname' ],
+ 'text_h' => [ \&text, 'self, text' ],
+ 'declaration_h' => [ \&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;
+
+ $p->utf8_mode(1);
+
+ $p->{'eat_tag'} = { map { $_ => 1 }
+ qw(script object iframe applet embed param) };
+
+ ## Enabling tag 'iframe' if need
+ delete $p->{'eat_tag'}->{'iframe'} if $opts{'enable_iframe'};
+
+ bless $p, $class;
+}
+
+my %bad_attr = (map { $_ => 1 }
+ qw(datasrc datafld));
+
+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 ( $self->{'eat_tag'}->{$tagname} && ! grep { lc $tagname eq $_ } @allowed_tags )
+ || $tagname =~ /^(?:g|fb):/;
+
+ 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/</</g;
+ $a =~ s/>/>/g;
+ return $a;
+}
+
+sub ehtml {
+ my $a = shift;
+ $a =~ s/\&/&/g;
+ $a =~ s/\"/"/g;
+ $a =~ s/\'/&\#39;/g;
+ $a =~ s/</</g;
+ $a =~ s/>/>/g;
+ return $a;
+}
+
+1;
diff -r 2a10b7c4ccd1 -r 7ed5651ee848 cgi-bin/S2/Color.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/S2/Color.pm Tue May 01 06:32:50 2012 +0000
@@ -0,0 +1,176 @@
+#
+# This code was forked from the LiveJournal project owned and operated
+# by Live Journal, Inc. The code has been modified and expanded by
+# Dreamwidth Studios, LLC. These files were originally licensed under
+# the terms of the license supplied by Live Journal, Inc, which can
+# currently be found at:
+#
+# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
+#
+# In accordance with the original license, this code and all its
+# modifications are provided under the GNU General Public License.
+# A copy of that license can be found in the LICENSE file included as
+# part of this distribution.
+#
+
+package S2::Color;
+use strict;
+
+# This is a helper package, useful for creating color lightening/darkening
+# functions in core layers.
+#
+
+# rgb to hsv
+# r, g, b = [0, 255]
+# h, s, v = [0, 1), [0, 1], [0, 1]
+sub rgb_to_hsv
+{
+ my ($r, $g, $b) = map { $_ / 255 } @_;
+ my ($h, $s, $v);
+
+ my ($max, $min) = ($r, $r);
+ foreach ($g, $b) {
+ $max = $_ if $_ > $max;
+ $min = $_ if $_ < $min;
+ }
+ return (0, 0, 0) if $max == 0;
+
+ $v = $max;
+
+ my $delta = $max - $min;
+
+ $s = $delta / $max;
+ return (0, $s, $v) unless $delta;
+
+ if ($r == $max) {
+ $h = ($g - $b) / $delta;
+ } elsif ($g == $max) {
+ $h = 2 + ($b - $r) / $delta;
+ } else {
+ $h = 4 + ($r - $g) / $delta;
+ }
+
+ $h = ($h * 60) % 360 / 360;
+
+ return ($h, $s, $v);
+}
+
+# hsv to rgb
+# h, s, v = [0, 1), [0, 1], [0, 1]
+# r, g, b = [0, 255], [0, 255], [0, 255]
+sub hsv_to_rgb
+{
+ my ($H, $S, $V) = @_;
+
+ if ($S == 0) {
+ $V *= 255;
+ return ($V, $V, $V);
+ }
+
+ $H *= 6;
+ my $I = POSIX::floor($H);
+
+ my $F = $H - $I;
+ my $P = $V * (1 - $S);
+ my $Q = $V * (1 - $S * $F);
+ my $T = $V * (1 - $S * (1 - $F));
+
+ foreach ($V, $T, $P, $Q) {
+ $_ = int($_ * 255 + 0.5);
+ }
+
+ return ($V, $T, $P) if $I == 0;
+ return ($Q, $V, $P) if $I == 1;
+ return ($P, $V, $T) if $I == 2;
+ return ($P, $Q, $V) if $I == 3;
+ return ($T, $P, $V) if $I == 4;
+
+ return ($V, $P, $Q);
+}
+
+# rgb to hsv
+# r, g, b = [0, 255], [0, 255], [0, 255]
+# returns: (h, s, l) = [0, 1), [0, 1], [0, 1]
+sub rgb_to_hsl
+{
+ # convert rgb to 0-1
+ my ($R, $G, $B) = map { $_ / 255 } @_;
+
+ # get min/max of {r, g, b}
+ my ($max, $min) = ($R, $R);
+ foreach ($G, $B) {
+ $max = $_ if $_ > $max;
+ $min = $_ if $_ < $min;
+ }
+
+ # is gray?
+ my $delta = $max - $min;
+ if ($delta == 0) {
+ return (0, 0, $max);
+ }
+
+ my ($H, $S);
+ my $L = ($max + $min) / 2;
+
+ if ($L < 0.5) {
+ $S = $delta / ($max + $min);
+ } else {
+ $S = $delta / (2.0 - $max - $min);
+ }
+
+ if ($R == $max) {
+ $H = ($G - $B) / $delta;
+ } elsif ($G == $max) {
+ $H = 2 + ($B - $R) / $delta;
+ } elsif ($B == $max) {
+ $H = 4 + ($R - $G) / $delta;
+ }
+
+ $H *= 60;
+ $H += 360.0 if $H < 0.0;
+ $H -= 360.0 if $H >= 360.0;
+ $H /= 360.0;
+
+ return ($H, $S, $L);
+
+}
+
+# h, s, l = [0,1), [0,1], [0,1]
+# returns: rgb: [0,255], [0,255], [0,255]
+sub hsl_to_rgb {
+ my ($H, $S, $L) = @_;
+
+ # gray.
+ if ($S < 0.0000000000001) {
+ my $gv = int(255 * $L + 0.5);
+ return ($gv, $gv, $gv);
+ }
+
+ my ($t1, $t2);
+ if ($L < 0.5) {
+ $t2 = $L * (1.0 + $S);
+ } else {
+ $t2 = $L + $S - $L * $S;
+ }
+ $t1 = 2.0 * $L - $t2;
+
+ my $fromhue = sub {
+ my $hue = shift;
+ if ($hue < 0) { $hue += 1.0; }
+ if ($hue > 1) { $hue -= 1.0; }
+
+ if (6.0 * $hue < 1) {
+ return $t1 + ($t2 - $t1) * $hue * 6.0;
+ } elsif (2.0 * $hue < 1) {
+ return $t2;
+ } elsif (3.0 * $hue < 2.0) {
+ return ($t1 + ($t2 - $t1)*((2.0/3.0)-$hue)*6.0);
+ } else {
+ return $t1;
+ }
+ };
+
+ return map { int(255 * $fromhue->($_) + 0.5) } ($H + 1.0/3.0, $H, $H - 1.0/3.0);
+}
+
+1;
diff -r 2a10b7c4ccd1 -r 7ed5651ee848 cvs/multicvs.conf
--- a/cvs/multicvs.conf Tue May 01 06:27:29 2012 +0000
+++ b/cvs/multicvs.conf Tue May 01 06:32:50 2012 +0000
@@ -26,7 +26,6 @@
GIT(Data-ObjectDriver) = git://github.com/saymedia/data-objectdriver.git
#SVN(openid) = http://code.livejournal.org/svn/openid/trunk/
SVN(ddlockd) = http://code.livejournal.org/svn/ddlockd/trunk/
-SVN(miscperl) = http://code.livejournal.org/svn/miscperl/trunk/
SVN(LJ-UserSearch) = http://code.livejournal.org/svn/LJ-UserSearch/trunk/
SVN(TheSchwartz-Worker-SendEmail) = http://code.sixapart.com/svn/TheSchwartz-Worker-SendEmail/trunk/
SVN(hubbub) = http://pubsubhubbub.googlecode.com/svn/trunk/publisher_clients/
@@ -51,11 +50,6 @@
js/ htdocs/js
js/ImageRegionSelect/image-region-select.js htdocs/js/image-region-select.js
-miscperl/DBI/Role.pm cgi-bin/DBI/Role.pm
-miscperl/HTMLCleaner.pm cgi-bin/HTMLCleaner.pm
-miscperl/S2/Color.pm cgi-bin/S2/Color.pm
-miscperl/Danga-Daemon/Daemon.pm cgi-bin/Danga/Daemon.pm
-
s2/ src/s2
s2/doc/docbook doc/raw/s2
--------------------------------------------------------------------------------