Message::Style - Perl module to perform stylistic analysis of messages

  use Message::Style;

  my $score=Message::Style::score(\@article);
  # or
  my $score=Message::Style::score(@article);

package Message::Style;
require 5.005;
use strict;
use vars qw( $VERSION @ISA );
# $Id: Style.pm,v 1.3 2004/10/26 15:53:37 abuse Exp $
$VERSION = do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf "%d."."%03d"x$#r,@r };

#use Carp;
#use Data::Dumper;

# =item 6.
#
#Capitalisation. Score Byte and Line points (the latter by
#heuristic) for each capitalised letter beyond 20% of the original
#material. (Not yet done).

sub score {
  my $aref=ref $_[0] ? $_[0] : \@_;

  # warning, neophyte code, only recently dredged up from the
  # archives, marginally cleaned-up, and turned into a CPANable module
    my @article=();
    my @header=();
    my %fault=();
    my %header=();
    my %meta=();
    my $t="";
    my ($lscore, $bscore)=(0,0);

  while(@$aref) {
    $_=shift @$aref;
    chomp;
    last unless length;
    push @header, $_;
  }

    @article=@$aref;
  chomp @article;

    # Firstly, the header is parsed. Folded lines are unfolded, and a
    # hash of header names vs. values is created. Dupes and duff
    # headers are noted.
    foreach(reverse @header) {
	# Join folded lines
	$t="$_$t";
	unless(/^[\t\ ]/) { # not folded
	    chomp $t;
	    if($t=~/^([A-Za-z0-9-]+)\: (.*)$/) {
		$fault{"Duplicated header: $1: $2"}++ if(exists $header{$1});
		$header{lc $1}=$2;
		$t="";
	    } else {
		$fault{"No colon-space in header ($t)"}++;
	    }
	}
    }

    # Check if this is a plain text posting or something else.

    if(defined $header{'content-type'}
       and $header{'content-type'}!~/^text\/plain/i) {
	$fault{"Non plaintext content: $header{'content-type'}"}++;
	$meta{isbinary}++;
    }

    if(defined $header{'content-transfer-encoding'}
       and $header{'content-transfer-encoding'}!~/^(7bit|8bit|quoted-printable)/i) {
	$fault{"Non plaintext encoding: $header{'content-transfer-encoding'}"}++;
	$meta{isbinary}++;
    }

    foreach my $line (@article) {
	# @words is a list of words in this line
	my @words=grep { $_ ne '' } split(/\s+/, $line);
	my $len=length $line; # For speed

	# Check for indentation, $qlevel contains level of indentation.
	# 0=original material, >=1 is quoted
	my $qlevel=0;
	$_=$line;
	s/\s+//g;
	$qlevel=length $1 if /(^\>*)/;

	# Check for long lines
	if(length($line)>80) {
	    $meta{toolong}++ if $len>80;
	    $meta{maxlen}=$len
		unless exists $meta{maxlen} and $meta{maxlen}>$len;
	    $lscore+=int($len/80);
	}
	
	if(scalar @words) { # Nonblank line
	    if($words[0]=~/^\>/) { # Quoted material
		$meta{qlines}++;
		$meta{qwords}+=scalar @words;
		$meta{qchars}+=length;
	    } else { # "Original" material
		$meta{olines}++;
		$meta{owords}+=scalar @words;
		$meta{ochars}+=length;
		foreach(@words) { # Crude check for BUAGs
		    if(/[^A-Za-z0-9]{3,}/) {
			next if m#(\.{3,3}|://)#;
			$meta{buag}++;
			last;
		    }
		}
	    }
	}

	# Check for and count signature
	if(exists $meta{hassig}) {
	    $meta{siglines}++;
	    if(exists $meta{siglines} && $meta{siglines}>4) {
		$lscore++;
		$bscore+=$len;
	    } elsif($len>80) {
		$fault{'Wide signature'}++;
		$lscore+=$len-80;
	    }
	}
	$meta{hassig}++ if(/^--\ ?$/);
	$fault{'Broken sigsep'}++
	    if($line eq '--');

#	if(/-----BEGIN PGP SIGNATURE-----/
#	   .. /-----END PGP SIGNATURE-----/) {
#	    $fault{'PGP signature'}++;
#	    next;
#	}

    }

    # Let's start moaning
    if(exists $meta{siglines} and $meta{siglines}>4) {
	$fault{"Signature is $meta{siglines} lines, should be four at most"}++;
	# Score already applied
    };

    if(exists $meta{buag} and $meta{buag}>10) {
	$fault{"Large BUAG/nontext present"}++;
	# No score, just a warning
    }

    if(exists $meta{toolong}) {
	$fault{"Overlong lines ($meta{toolong} of them), longest is $meta{maxlen} chars"}++;
	# Score already applied
    }

    if(exists $meta{isbinary}) {
	# Apply score to *whole* article
	map { $bscore+=length; $lscore++ } @header;
	map { $bscore+=length; $lscore++ } @article;
    }

  my $groups=1;
  $groups=($header{newsgroups}=~tr[,][,])+1
    if defined $header{newsgroups};
    my $score=int(($lscore*40+$bscore)*sqrt $groups);
    my $name=$header{from};

    if($lscore|$bscore) {
	$fault{"Score: $score"}++;
	$fault{"Lscore: $lscore, Bscore: $bscore, Groups: $groups"}++;
    }

  # You may correctly assume that this code was ripped from something
  # that used %fault, even though this package doesn't do anything
  # useful with it.

#  carp Dumper \@article, \%fault, \%meta;

  return $score;

  # end neophyte code. May @DEITY smile upon me one day to have the
  # tuits to clean up the code and turn it into a useful package.
}

  
1;