Author: coar
Date: Fri Nov 5 20:32:42 2010
New Revision: 1031779
URL: http://svn.apache.org/viewvc?rev=1031779&view=rev
Log:
Changing the name -- NOT READY FOR LIVE DEPLOYMENT!
Added:
labs/pulse/collection/pulse-collect.pl
- copied, changed from r1030201, labs/pulse/collection/aplists.pl
Removed:
labs/pulse/collection/aplists.pl
Copied: labs/pulse/collection/pulse-collect.pl (from r1030201,
labs/pulse/collection/aplists.pl)
URL:
http://svn.apache.org/viewvc/labs/pulse/collection/pulse-collect.pl?p2=labs/pulse/collection/pulse-collect.pl&p1=labs/pulse/collection/aplists.pl&r1=1030201&r2=1031779&rev=1031779&view=diff
==============================================================================
--- labs/pulse/collection/aplists.pl (original)
+++ labs/pulse/collection/pulse-collect.pl Fri Nov 5 20:32:42 2010
@@ -1,14 +1,21 @@
#! /usr/bin/perl -w
#
+# Read the Apache mailing list information, load it into a DOM
+# structure, and emit it as XML.
+#
# aplists.pl [options] [list-parent-directory]
#
# -h help/usage
-# -c count messages in last 24 hours
+# -c count messages in last 24 hours with find(1)
+# -C count messages in last 24 hours using EZMLM message counters
# -o include public lists (subscription not moderated)
# -O don't include public lists
# -p include private lists (subscription moderated)
# -P don't include private lists
# -a include both public and private lists
+# -s include subscribers
+# -S don't include subscribers
+# -u record list message counters in SDBM file
# -x Generate output in XML format
#
# Output format is one line per list:
@@ -25,7 +32,11 @@
# <subscribers>int</subscribers>
# <digest-subscribers>int</digest-subscribers>
# <info>encoded-info</info>
-# <messages>int</messages> <!-- optional -->
+# <messages>int</messages> <!-- optional -->
+# <subscribers> <!-- based on -s -->
+# <eddress><![CDATA[eddress]]></eddress> <!-- : -->
+# : <!-- : -->
+# </subscribers> <!-- : -->
# </list>
# <list>...
# </site>
@@ -33,44 +44,560 @@
# </mailing-lists>
#
use strict;
+use Carp;
+use Data::Dumper;
+use Date::Manip qw( ParseDateString );
use Getopt::Long;
-use Symbol;
use POSIX;
-#use XML::LibXML::Common qw(:encoding);
+use Symbol;
+use XML::LibXML::Common qw(:encoding);
+
+{
+ package Pulse;
+
+ use Carp;
+ use Data::Dumper;
+ use Fcntl;
+ use POSIX;
+ use SDBM_File;
+
+ our $DebugLevel = 1;
+
+ sub accessors {
+
+ my ($class, @fields) = @_;
+ return unless (@fields);
+ my $caller = caller();
+
+ #
+ # Build the code we're going to eval for the caller
+ # Do the fields call for the calling package
+ #
+ my $eval = "package $caller;\n"
+ . "use fields qw( " . join(' ', @fields) . ");\n";
+
+ # Generate convenient accessor methods
+ foreach my $field (@fields) {
+ local ($|);
+ $| = 1;
+ $eval .= "sub $field : lvalue { \$_[0]->{$field} }\n"
+ unless ($caller->can($field));
+ }
+
+ # Eval the code we prepared
+ eval($eval);
+
+ # $@ holds possible eval errors
+ $@ and die "Error setting members for $caller: $@";
+ }
+
+ sub mkpath {
+ my $self = shift;
+ return join('/', $self->path, @_);
+ }
+
+ sub debug {
+ shift if ((ref($_[0])) || ($_[0] eq __PACKAGE__));
+ my $level = 1;
+ if ($_[0] =~ /^\d+$/) {
+ $level = shift;
+ }
+ if ($Pulse::DebugLevel >= $level) {
+ print "debug[$level]: " . join(' ', @_) . "\n";
+ }
+ }
+
+ #
+ # Constructor
+ #
+ sub new {
+ my ($class, $path, @args) = @_;
+ my $self = bless({}, ref($class) || $class);
+ $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
+ $self->accessors(qw(
+ asof
+ asofISO
+ counterDB
+ domains
+ eddresses
+ path
+ ));
+ $self->domains = {};
+ $self->eddresses = {};
+ $self->path = $path;
+ $self->asof = strftime('%Y-%m-%d %H:%M', localtime());
+ $self->asofISO = strftime('%Y-%m-%dT%H:00', localtime());
+ $self->counterDB = {};
+ tie(%{$self->counterDB},
+ 'SDBM_File',
+ $self->mkpath('pulse-message-counts.sdbm'),
+ O_RDWR | O_CREAT,
+ 0640);
+ return $self;
+ }
+
+ sub DESTROY {
+# untie(%{$self->counterDB}) if (ref($self->counterDB) eq 'HASH');
+ }
+
+ sub registerDomain {
+ my $self = shift;
+ my @added = ();
+ for my $domain (@_) {
+ my $dobject;
+ my $dname = ref($domain) ? $domain->name : $domain;
+ unless (exists($self->domains->{$dname})) {
+ $dobject = ref($domain)
+ ? $domain
+ : Domain->new($self, $dname, $self->{options});
+ $self->domains->{$dname} = $dobject;
+ }
+ push(@added, $dobject);
+ }
+ return \...@added;
+ }
+
+ sub registerEddress {
+ my $self = shift;
+ my @added = ();
+ for my $item (@_) {
+ my $name = ref($item) ? $item->name : $item;
+ unless (exists($self->eddresses->{$name})) {
+ my $object = ref($item)
+ ? $item
+ : Pulse::Eddress->new($name, $self->{options});
+ $self->eddresses->{$name} = $object;
+ }
+ push(@added, $self->eddresses->{$name});
+ }
+ return \...@added;
+ }
+
+ sub utf8_safe {
+ my ($class, $input) = @_;
+ my %table;
+ my $ichar;
+ for (my $i = 0; $i <= 0xFF; $i++) {
+ $ichar = chr($i);
+ if (($i == 0x09)
+ || ($i == 0x0A)
+ || ($i == 0x0D)
+ || (($i >= 0x20)
+ && ($i <= 0x7F))) {
+ $ichar = chr($i);
+# if ($ichar eq '<') {
+# $table{$ichar} = '<';
+# }
+# elsif ($ichar eq '>') {
+# $table{$ichar} = '>';
+# }
+# elsif ($ichar eq '&') {
+# $table{$ichar} = '&';
+# }
+ next;
+ }
+ if (($i < 0x7F)
+ || (($i >= 0x7F) && ($i <= 0x84))
+ || (($i >= 0x86) && ($i <= 0x9F))) {
+ $table{$ichar} = '*';
+ }
+ else {
+ $table{$ichar} = sprintf('&#x%02x;', $i);
+ }
+ }
+ my $output = '';
+ for (my $i = 0; $i < length($input); $i++) {
+ my $ichar = substr($input, $i, 1);
+ if (defined($table{$ichar})) {
+ $output .= $table{$ichar};
+ }
+ else {
+ $output .= $ichar;
+ }
+ }
+ return $output;
+ }
+}
+
+{
+ package Domain;
+
+ use Carp;
+ use Data::Dumper;
+
+ our @ISA = qw( Pulse );
+
+ #
+ # Constructor
+ #
+ sub new {
+ my ($class, $pulse, $domain, @args) = @_;
+ my $self = bless({}, ref($class) || $class);
+ $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
+ $self->accessors qw( name pulse lists path );
+ $self->name = $domain;
+ $self->pulse = $pulse;
+ $self->lists = {};
+ $self->path = $pulse->mkpath($domain);
+ return $self;
+ }
+
+ #
+ # Destructor
+ #
+ sub DESTROY {
+ }
+
+ sub registerList {
+ my $self = shift;
+ my @added = ();
+ for my $item (@_) {
+ my $name = ref($item) ? $item->name : $item;
+ unless (exists($self->lists->{$name})) {
+ my $object = ref($item)
+ ? $item
+ : Domain::List->new($self, $name, $self->{options});
+ $self->lists->{$name} = $object;
+ }
+ push(@added, $self->lists->{$name});
+ }
+ return \...@added;
+ }
+
+}
+
+{
+ package Domain::List;
+ our @ISA = qw( Domain );
+
+ use Carp;
+ use Data::Dumper;
+ use SDBM_File;
+ use Symbol;
+
+ #
+ # Constructor
+ #
+ sub new {
+ my ($class, $domain, $list, @args) = @_;
+ my $self = bless({}, ref($class) || $class);
+ $self->accessors(qw(
+ name
+ archived
+ digested
+ digesters
+ domain
+ info
+ messageCount
+ messageInterval
+ moderators
+ path
+ pulse
+ public
+ subscribers
+ ));
+ $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
+ $self->messageInterval = $self->{options}->{CountInterval} || 1;
+ ($list, undef) = split(/\@/, $list, 1);
+ croak(__PACKAGE__ . ' constructor requires a Domain object')
+ unless (ref($domain) eq 'Domain');
+ $self->name = $list;
+ $self->domain = $domain;
+ $self->pulse = $domain->pulse;
+ $self->path = $domain->mkpath($list);
+ my $cfh = gensym();
+ my $cfgpath = $self->mkpath('config');
+ open($cfh, "< $cfgpath")
+ or croak("Can't opendir($cfgpath): $!");
+ my @cfglines = <$cfh>;
+ close($cfh);
+ @cfglines = grep(/^F:/, @cfglines);
+ croak("Can't find F: config line in $cfgpath")
+ unless (@cfglines == 1);
+ $self->public = $cfglines[0] =~ /S/;
+ $self->archived = $cfglines[0] =~ /a/;
+ $self->digested = $cfglines[0] =~ /d/;
+ if ($self->{options}->{IncludeInfo}) {
+ my $ifile = $self->mkpath('text/info');
+ my $info;
+ if (-r $ifile) {
+ open($cfh, "< $ifile")
+ or croak("Can't open $ifile: $!");
+ my @info = <$cfh>;
+ close($cfh);
+ $info = join('', @info);
+ $info = Pulse->utf8_safe($info);
+ }
+ else {
+ $info = "No information has been provided\n";
+ }
+ $self->info = $info;
+ }
+ my @eddresses;
+ my $cmd;
+
+ if ($self->{options}->{IncludeSubscribers}) {
+ $self->subscribers = {};
+ $cmd = 'ezmlm-list -N ' . $self->path;
+ open($cfh, "$cmd |")
+ or croak("Unable to open pipe for '$cmd': $!");
+ @eddresses = <$cfh>;
+ close($cfh);
+ chomp(@eddresses);
+ for my $eddress (@eddresses) {
+ $eddress = Pulse->utf8_safe($eddress);
+ $self->registerSubscriber($eddress);
+ }
+ $self->debug(4,
+ 'Loaded '
+ . scalar(keys(%{$self->subscribers}))
+ . ' subscribers');
+
+ $self->moderators = {};
+ $cmd = 'ezmlm-list -N ' . $self->mkpath('mod');
+ open($cfh, "$cmd |")
+ or croak("Unable to open pipe for '$cmd': $!");
+ @eddresses = <$cfh>;
+ close($cfh);
+ chomp(@eddresses);
+ for my $eddress (@eddresses) {
+ $eddress = Pulse->utf8_safe($eddress);
+ $self->registerModerator($eddress);
+ }
+ $self->debug(4,
+ 'Loaded '
+ . scalar(keys(%{$self->moderators}))
+ . ' moderators');
+
+ $self->digesters = {};
+ if ($self->digested) {
+ $cmd = 'ezmlm-list -N ' . $self->mkpath('digest');
+ open($cfh, "$cmd |")
+ or croak("Unable to open pipe for '$cmd': $!");
+ @eddresses = <$cfh>;
+ close($cfh);
+ chomp(@eddresses);
+ for my $eddress (@eddresses) {
+ $eddress = Pulse->utf8_safe($eddress);
+ $self->registerDigester($eddress);
+ }
+ $self->debug(4, 'Loaded ' . scalar(keys(%{$self->digesters}))
+ . ' digest subscribers');
+ }
+ }
+ my $file = $self->mkpath('num');
+ my $key1 = $self->fullname . ':';
+ my $key = $key1 . $self->pulse->asofISO;
+ my @stamps = grep(/^$key1/, keys(%{$self->pulse->counterDB}));
+ Pulse->debug(4, scalar(@stamps) . ' recorded counters');
+ my $counters;
+ if (-f $file) {
+ open($cfh, "< $file")
+ or croak("Can't open $file: $!");
+ $counters = <$cfh>;
+ close($cfh);
+ chomp($counters);
+ if ($self->{options}->{UpdateCounters}) {
+ $self->pulse->counterDB->{$key} = $counters;
+ if (my $when = $self->{options}->{WeedDate}) {
+ my $threshold = $key1 . $when;
+ my @doomed = grep({ $_ lt $threshold } @stamps);
+ if (@doomed) {
+ Pulse->debug(4,
+ scalar(@doomed)
+ . ' recorded counters to weed');
+ delete(@{$self->pulse->counterDB}{(@doomed)});
+ }
+ }
+ }
+ }
+ if ($self->{options}->{UseCounters}) {
+ my $threshold = strftime('%Y-%m-%dT%H:%M',
+ localtime() - 24 * 60 * 60);
+ $threshold = $self->fullname . ':' . $threshold;
+ my @earlier = grep( { $_ le $threshold } @stamps);
+ $threshold = strftime('%Y-%m-%dT%H:%M',
+ localtime() - 48 * 60 * 60);
+ my ($stamp, @trash) = sort(grep( { $_ le $threshold } @stamps));
+ if ($stamp) {
+ my ($now) = split(/:/, $self->pulse->counterDB->{$key});
+ my ($then) = split(/:/, $self->pulse->counterDB->{$stamp});
+ $self->messageCount = int($now) - int($then);
+ }
+ }
+ elsif ($self->{options}->{CountMessages}) {
+ $self->countMessages($self->messageInterval);
+ }
+ return $self;
+ }
+
+ sub fullname {
+ my $self = shift;
+ return $self->name . '@' . $self->domain->name;
+ }
+
+ sub countMessages {
+ my $self = shift;
+ my $interval = $_[0] || $self->{options}->{CountInterval};
+ $self->messageCount = -1;
+ if ($self->archived) {
+ $self->debug(4, "Locating messages from last $interval day(s)");
+ my $cmd = sprintf('find %s/archive -mtime -%d -type f -name
\[0-9\]*'
+ . ' | wc -l |',
+ $self->path, $interval);
+ my $cfh = gensym();
+ open($cfh, $cmd)
+ or croak("Unable to execute '$cmd': $!");
+ my $msgs = <$cfh>;
+ close($cfh);
+ $msgs =~ /(\d+)/;
+ $self->messageCount = $1;
+ }
+ }
+
+ sub registerSubscriber {
+ my $self = shift;
+ my @added = ();
+ for my $item (@_) {
+ my $name = ref($item) ? $item->name : $item;
+ unless (exists($self->subscribers->{$name})) {
+ my $object = ref($item)
+ ? $item
+ : Pulse::Eddress->new($name, $self->{options});
+ $self->domain->pulse->registerEddress($object);
+ $self->subscribers->{$name} = $object;
+ }
+ push(@added, $self->subscribers->{$name});
+ }
+ return \...@added;
+ }
+
+ sub registerDigester {
+ my $self = shift;
+ my @added = ();
+ for my $item (@_) {
+ my $name = ref($item) ? $item->name : $item;
+ unless (exists($self->digesters->{$name})) {
+ my $object = ref($item)
+ ? $item
+ : Pulse::Eddress->new($name, $self->{options});
+ $self->domain->pulse->registerEddress($object);
+ $self->digesters->{$name} = $object;
+ }
+ push(@added, $self->digesters->{$name});
+ }
+ return \...@added;
+ }
+
+ sub registerModerator {
+ my $self = shift;
+ my @added = ();
+ for my $item (@_) {
+ my $name = ref($item) ? $item->name : $item;
+ unless (exists($self->moderators->{$name})) {
+ my $object = ref($item)
+ ? $item
+ : Pulse::Eddress->new($name, $self->{options});
+ $self->domain->pulse->registerEddress($object);
+ $self->moderators->{$name} = $object;
+ }
+ push(@added, $self->moderators->{$name});
+ }
+ return \...@added;
+ }
+
+}
+
+{
+ package Pulse::Eddress;
+
+ use Carp;
+ use Data::Dumper;
+
+ our @ISA = qw( Pulse );
+
+ #
+ # Constructor
+ #
+ sub new {
+ my ($class, $eddress, @args) = @_;
+ my $self = bless({}, ref($class) || $class);
+ $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
+ $self->accessors qw( name );
+ $self->name = $eddress;
+ return $self;
+ }
+}
+
+package main;
my %options;
my $include_public = 1;
my $include_private = 0;
+my $include_subscribers = 0;
my $use_xml = 0;
my $count = 0;
+my $usemsgcounters = 0;
+my $updatemsgcounters = 0;
my $debug = 0;
+my $include_info = 0;
+my $weed_date = '';
my $phandle = gensym();
Getopt::Long::Configure('bundling');
GetOptions(\%options,
- 'a' => sub { $include_public = $include_private = 1; },
- 'c' => \$count,
- 'd+' => \$debug,
- 'h' => \&usage,
- 'o' => \$include_public,
- 'O' => sub { $include_public = 0; },
- 'p' => \$include_private,
- 'P' => sub { $include_private = 0; },
- 'x' => \$use_xml,
+ 'all|a' => sub { $include_public = $include_private = 1; },
+ 'count-message-files|c' => \$count,
+ 'use-message-counters|C' => \$usemsgcounters,
+ 'debug|d+' => \$debug,
+ 'help|h' => \&usage,
+ 'include-info|i' => \$include_info,
+ 'include-public-lists|o' => \$include_public,
+ 'noinclude-public-lists|O' => sub { $include_public = 0; },
+ 'include-private-lists|p' => \$include_private,
+ 'noinclude-private-lists|P' => sub { $include_private = 0; },
+ 'include-subscribers|s' => \$include_subscribers,
+ 'noinclude-subscribers|S' => sub { $include_subscribers = 0; },
+ 'update-message-counters|u' => \$updatemsgcounters,
+ 'weed-counters|w:s' => \$weed_date,
+ 'x' => \$use_xml,
);
-
#
# No counting if we're not generating XML..
#
$count = 0 if ($count && (! $use_xml));
+if ($weed_date) {
+ ParseDateString($weed_date) =~ m/(\d{4})(\d{2})(\d{2})
+ (\d{2}):?(\d{2}):?(\d{2})/x;
+ $weed_date = sprintf('%04d-%02d-%02dT%02d:%02d', $1, $2, $3, $4, $5);
+}
+
+$Pulse::DebugLevel = $debug;
+Pulse->debug('public =', $include_public);
+Pulse->debug('private =', $include_private);
+Pulse->debug('getInfo =', $include_info);
+Pulse->debug('subscribers =', $include_subscribers);
+Pulse->debug('countMessages =', $count);
+Pulse->debug('useMessageCounts =', $usemsgcounters);
+Pulse->debug('updateMessageCounts =', $updatemsgcounters);
+Pulse->debug('weedDate =', $weed_date);
-debug('public =', $include_public);
-debug('private =', $include_private);
+my $TLD = $ARGV[0] || '/home/apmail/lists';
my $tlh = gensym();
my $slh = gensym();
-
-my $TLD = $ARGV[0] || '/home/coar/apache-apmail/lists';
+my $pulse = Pulse->new($TLD,
+ {
+ CountMessages => $count,
+ IncludeInfo => $include_info,
+ IncludePrivate => $include_private,
+ IncludePublic => $include_public,
+ IncludeSubscribers => $include_subscribers,
+ UpdateCounters => $updatemsgcounters,
+ UseCounters => $usemsgcounters,
+ WeedDate => $weed_date,
+ }
+ );
opendir($tlh, $TLD) or die("Can't opendir($TLD): $!");
my @tldirs = readdir($tlh);
closedir($tlh);
@@ -79,234 +606,77 @@ closedir($tlh);
# @tldirs now has a list of all the sites. Scan each one for the
# lists on that site.
#
-my %lists;
-for my $tldir (@tldirs) {
- next if ($tldir !~ /\w\.\w+$/i);
- next if (! -d "$TLD/$tldir");
- opendir($slh, "$TLD/$tldir") or die("Can't opendir($TLD/$tldir): $!");
+
+for my $site (@tldirs) {
+ my $domain = $pulse->registerDomain($site)
+ unless (($site =~ /^(?:\.+|cvs)$/i)
+ || (! -d "$TLD/$site"));
+}
+Pulse->debug(1, 'Domains loaded: ' . scalar(keys(%{$pulse->domains})));
+
+my $listcount = 0;
+for my $dname (sort(keys(%{$pulse->domains}))) {
+ my $domain = $pulse->domains->{$dname};
+ Pulse->debug(2, "Getting lists for $dname");
+ opendir($slh, $domain->path)
+ or die("Can't opendir(" . $domain->path . "): $!");
my @sldirs = readdir($slh);
closedir($slh);
- for my $sldir (@sldirs) {
- next if ($sldir =~ /^(?:\.+|cvs)$/i);
- next if (! -d "$TLD/$tldir/$sldir");
- push(@{$lists{$tldir}}, $sldir);
+ for my $ldir (sort(@sldirs)) {
+ my $lpath = $domain->path . '/' . $ldir;
+ next unless ((-d $lpath) && (-f "$lpath/config"));
+ Pulse->debug(3, "Loading list $ldir\@" . $domain->name);
+ my $list = $domain->registerList($ldir);
+ $listcount++;
}
}
+Pulse->debug(1, scalar(keys(%{$pulse->eddresses})) . ' total eddresses');
+Pulse->debug(1, $listcount . ' total lists');
+Pulse->debug(1, 'Done loading data from filesystem');
+
if ($use_xml) {
- print "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
- . "<mailing-lists>\n";
- print ' <asof>' . strftime('%Y-%m-%d', localtime()) . "</asof>\n";
-}
-my $ifile = gensym();
-for my $site (sort(keys(%lists))) {
- if ($use_xml) {
- print " <site>\n"
- . " <name>$site</name>\n";
- }
- else {
- print "$site:";
- }
- my $continue = 0;
- for my $list (sort(@{$lists{$site}})) {
- my $is_archived;
- my $cmd;
- #
- # Assume the list is public in case we can't figure it out.
- #
- my $public = 1;
- my $is_digested = 1;
- my $config = "$TLD/$site/$list/config";
- if (open(CONFIG, "< $config")) {
- while (<CONFIG>) {
- if (/^F:/) {
- debug(2, "found config line for $li...@$site: $_");
- $public = ($_ =~ /S/);
- $is_archived = ($_ =~ /a/);
- $is_digested = ($_ =~ /d/);
- last;
- }
- }
- close(CONFIG);
- }
- debug(3, "$li...@$site is " . ($public ? '' : 'not ') . 'public');
- debug(3, "$li...@$site is " . ($is_archived ? '' : 'not ') .
'archived');
- next if (($public && (! $include_public))
- || ((! $public) && (! $include_private)));
- if ($continue) {
- if (! $use_xml) {
- print ',';
- }
- }
- if ($use_xml) {
- print " <list>\n"
- . " <name>$list</name>\n"
- . ' <status>'
- . ($public ? 'public' : 'private')
- . "</status>\n";
- }
- else {
- print $list;
- }
- my $info = "$TLD/$site/$list/text/info";
- if (-r $info) {
- if ($use_xml) {
- open($ifile, "< $info");
- my @slurp = <$ifile>;
- close($ifile);
- my $slurp = join('', @slurp);
- if ($slurp !~ /^No information has been provided /) {
- $slurp = utf8_safe($slurp);
-# $slurp = encodeToUTF8('ISO-8859-1', $slurp);
- chomp($slurp);
- print " <info>\n"
- . "<![CDATA[$slurp]]>\n"
- . " </info>\n";
- }
- }
- else {
- print "=$info";
- }
- }
- $cmd = "ezmlm-list -n $TLD/$site/$list |";
- open($phandle, $cmd)
- and do {
- my $subs = <$phandle>;
- close($phandle);
- $subs =~ /(\d+)/;
- $subs = $1;
- print " <subscribers>$subs</subscribers>\n";
- };
- if ($is_digested) {
- $cmd = "ezmlm-list -n $TLD/$site/$list/digest |";
- open($phandle, $cmd)
- and do {
- my $subs = <$phandle>;
- close($phandle);
- $subs =~ /(\d+)/;
- $subs = $1;
- print ' <digest-subscribers>'
- . $subs
- . "</digest-subscribers>\n";
- };
- }
- if ($count) {
- my $msgs = -1;
- if ($is_archived) {
- $cmd = "find $TLD/$site/$list/archive "
- . "-mtime -1 -type f -name '[0-9]*' "
- . '| wc -l |';
- debug(2, $cmd);
- open($phandle, $cmd)
- and do {
- $msgs = <$phandle>;
- close($phandle);
- chomp($msgs);
- debug(3, "msgs = '$msgs'");
- $msgs =~ /(\d+)/;
- $msgs = $1;
- };
- }
- print " <messages>$msgs</messages>\n";
- }
- my $ph = gensym();
- my $mods = '';
- $cmd = "ezmlm-list $TLD/$site/$list/mod |";
- debug(2, $cmd);
- open($ph, $cmd)
- and do {
- my @mods = <$ph>;
- close($ph);
- chomp(@mods);
- $mods = join(' ', @mods);
- debug(3, "mods = '$mods'");
- };
- if ($mods) {
- $mods = utf8_safe($mods);
-# $mods = encodeToUTF8('ISO-8859-1', $mods);
- print " <moderators><![CDATA[$mods]]></moderators>\n";
- }
- if ($use_xml) {
- print " </list>\n";
+ Pulse->debug(1, 'Building DOM structure');
+ my $doc = XML::LibXML::Document->new();
+ my $root = $doc->createElement('mailing-lists');
+ $doc->setDocumentElement($root);
+
+ my $domains = $pulse->domains;
+ for my $dname (sort(keys(%{$domains}))) {
+ my $domain = $domains->{$dname};
+ my $domain_object = $doc->createElement('site');
+ $root->appendChild($domain_object);
+ Pulse->debug(2, "Adding domain $dname to DOM");
+ my $object = $doc->createElement('name');
+ $object->appendChild($doc->createTextNode($dname));
+ $domain_object->appendChild($object);
+ for my $lname (sort(keys(%{$domain->lists}))) {
+ my $list = $domain->lists->{$lname};
+ my $list_object = $doc->createElement('list');
+ $domain_object->appendChild($list_object);
+ Pulse->debug(3, "Adding list $lna...@$dname to DOM");
+ $list_object->appendTextChild('name', $lname);
+ $list_object->appendTextChild('status',
+ ($list->public
+ ? 'public'
+ : 'private'));
+ $object = $doc->createElement('info');
+ my $cdata = $doc->createCDATASection($list->info || '');
+ $object->appendChild($cdata);
+ $list_object->appendChild($object);
}
}
- if ($use_xml) {
- print " </site>\n";
- }
- else {
- print "\n";
- }
-}
-if ($use_xml) {
- print "</mailing-lists>\n";
-}
-#
-# Help display
-#
-sub usage {
- print STDERR "Usage: $0 [-ahpP] [list-parent]\n"
- . " -a Include both public and private lists\n"
- . " -h This message\n"
- . " -o Include open (public) lists (default)\n"
- . " -O Do not include open lists\n"
- . " -p Include closed (private) lists\n"
- . " -P Do not include closed lists (default)\n";
- exit(0);
+ print $doc->toString(1);
}
+#print Dumper([ keys(%{$pulse->{domainhash}}) ]);
+exit;
-sub debug {
- my $level = 1;
- if ($_[0] =~ /^\d+$/) {
- $level = shift;
- }
- if ($debug >= $level) {
- print 'debug: ' . join(' ', @_) . "\n";
- }
-}
-sub utf8_safe {
- my ($input) = @_;
- my %table;
- my $ichar;
- for (my $i = 0; $i <= 0xFF; $i++) {
- $ichar = chr($i);
- if (($i == 0x09)
- || ($i == 0x0A)
- || ($i == 0x0D)
- || (($i >= 0x20)
- && ($i <= 0x7F))) {
- $ichar = chr($i);
-# if ($ichar eq '<') {
-# $table{$ichar} = '<';
-# }
-# elsif ($ichar eq '>') {
-# $table{$ichar} = '>';
-# }
-# elsif ($ichar eq '&') {
-# $table{$ichar} = '&';
-# }
- next;
- }
- if (($i < 0x7F)
- || (($i >= 0x7F) && ($i <= 0x84))
- || (($i >= 0x86) && ($i <= 0x9F))) {
- $table{$ichar} = '*';
- }
- else {
- $table{$ichar} = sprintf('&#x%02x;', $i);
- }
- }
- my $output = '';
- for (my $i = 0; $i < length($input); $i++) {
- my $ichar = substr($input, $i, 1);
- if (defined($table{$ichar})) {
- $output .= $table{$ichar};
- }
- else {
- $output .= $ichar;
- }
- }
- return $output;
-}
+__END__
+my $list = Domain::List->new($domain, 'dev');
+$domain->addList($list);
+$list->addSubscriber('[email protected]','[email protected]');
+$list->addSubscriber('[email protected]','[email protected]');
+print Dumper($list);
#
# Local Variables:
---------------------------------------------------------------------
To unsubscribe, e-mail: [email protected]
For additional commands, e-mail: [email protected]
