File Coverage

blib/lib/Lingua/DE/Sentence.pm

Criterion	Covered	Total	%
statement	46	56	82.1
branch	35	40	87.5
condition	21	24	87.5
subroutine	6	12	50.0
pod	7	7	100.0
total	115	139	82.7

package Lingua::DE::Sentence;

require 5.005_62;
use strict;
use warnings;
use locale;

use POSIX qw(locale_h);
require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw( get_sentences get_acronyms set_acronyms add_acronyms
		     get_file_extensions set_file_extensions add_file_extensions);

our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

our @EXPORT = qw(get_sentences);

our $VERSION = '0.07';

# will be filled with known german abbrevations
my %ABBREVIATIONS;
# will be filled with some known file extensions
my %FILE_EXTENSIONS;

# contains "real" consonant sounds
# sch, ch, st, ss, ... are spoken as one sound, that's way ?> and the alternation
# bb, dd, ... are not so often, but often used in acronyms
my $CONSONANT = qr/
    (?>ff|ll|sch|ch|st|ss|mm|nn|pp|rr|tt|ck|pf|
     [bcdfghklmnpqrstvwxz])/x;

# common vocals in german
my $VOCAL = qr/[aeouiäöü]/;

# the characters that can be between sentences  (chr(150) is a dash, chr(160) is a nonbreaking whitespace)
my $LEADING_SENTENCE_CHAR = '[\s'.chr(150).chr(160).'?!>\#\.\-\*]';

# regexp for new lines (even DOS, or MAC - Mode)
my $NL = qr/(?>\r\n|\n|\r)/;

# Characters which could be quotation marks (171 and 187 are << and >> as one character)
my $QUOTE = q{\"\'<>} . chr(171) . chr(187);

# Punctation marks
my $PUNCT = q{\.!?};

# Preloaded methods go here.

sub get_sentences {
    # Set german locale
    my $old_locale = setlocale(LC_CTYPE);
    setlocale(LC_CTYPE, "de_DE");

    my ($text) = @_;
    my @pos = ();
    my @sentences;
    my ($leading_chars,$sent,$rest);
    my $last_pos = 0;
    while ($text =~ m/ (?!\w)                      # Sentence-End not at word characters
	               (?:
                          # normal end of Sentence like .?!
	                  [$PUNCT]                 # End of Sentence could be a punctation
	                  (?![^\w\r\n]*[$PUNCT,])  # and not as the first of some punctations (incl. comma)
	                  [$QUOTE()]*              # possibly followed by a quotation mark or bracket
	                |
                          # or an empty line
	                  (?=\s\s)                 # so there must be at least two whitespaces
	                  (?=\s*?$NL \s*?$NL)      # exact, two end of lines (perhaps with spaces)
			|
	                  \Z)/gsxo)                 # or end of file
    {
	($leading_chars,$sent)
	    = substr($text,$last_pos,-$last_pos+pos($text))
		=~ /^($LEADING_SENTENCE_CHAR*)(.*)$/s;
	$rest = substr($text,pos($text),100);

	# fix empty sentences
	# every sentence has to include anything
	$sent !~ m/\w/ && next;

        # check only special cases, if not at end of text or paragraph
	if ($rest =~ m/^(?!\s*?$NL\s*?$NL)\s*\S/so) {

            # fix bla bla" sagte er.
	    # in general it's a word followed by " or ' and followed by a lowercase word
	    $sent =~ /[$QUOTE]$/o && $rest =~ m/^[$QUOTE()\s]*([[:lower:]])/o && next;

	    # fix enumerations
	    $sent =~ /\W\.\.[$QUOTE\)]?$/o && $rest !~ /^(?:\s*$NL){2}/o && next;

	    # Abbrevations
	    # these are lower-Case words of length 1 (in german always)
	    # or in Abbr.-List (ignoriers Lower/UpperCase)
	    # or consists of only consonants
	    # or ends too curious, that means 4 consonants at the end
	    if ($sent =~ /([^\W\d]+)\.[$QUOTE\)]*?$/o) {
		length($1) == 1 and next;
		$_ = lc($1);
		$ABBREVIATIONS{$_} and next;
		/^$CONSONANT+$/o and next;
		/^$VOCAL+$/o and next;
		/$CONSONANT{4,}$/o and next;
	    }

	    # Ordinal-Numbers like 1., 2., ...
	    # I treat all numbers till 39 as ordinal
	    # plus the numbers ending on ..00
	    $sent =~ /\d\.$/ && $sent =~ /(?
		(($1 < 40) || (($_ = $1) =~ /00$/ and $_ != 1900 and $_ != 2000 and $_ != 2100)) && next;

	    # Rational Numbers, IP-Numbers, Phonenumbers like 127.32.2345
	    $sent =~ /\.$/ && $rest =~ /^\d/ && next;

	    # Something like Domain-Adresses, URLs and so on
	    $sent =~ m{ (?=[hfnmg])
			(?:http|file|ftp|news|mailto|gopher)
			://
                        [\w\d\.\%\_\/\:\-]+
                        (?
                      }xm
		&& next;
	    $rest =~ /^([[:lower:]][[:lower:]\d]*[\.\?:\/]?)+/o
		&& $sent =~ /([[:lower:]\d]+[\.\?:\/])+$/o && next;

	    # fix something like: Ich muss mich auf verschiedene (!) Browser einrichten.
	    $sent =~ / \(  [$QUOTE\.!?\)]+  $/xo && next;

	    # fix filenames like "document1.doc"
	    # look in extension list or extension consists of consonants
	    if ($sent =~ /\.$/ && $rest =~ /^(\w{1,4})\b/) {
		$FILE_EXTENSIONS{$_ = lc($1)} && next;
		/^$CONSONANT+$/o && next;
	    }
	}
	$last_pos = pos($text);
	push @sentences, $sent;
	push @pos, [pos($text) - length($sent) => pos($text)] if wantarray;
    }
    return wantarray ? (\@sentences, \@pos) : \@sentences;

    setlocale(LC_CTYPE, $old_locale);
}

sub get_acronyms {
    return keys %ABBREVIATIONS;
}

sub set_acronyms {
    %ABBREVIATIONS = map {$_ => 1} @_;
}

sub add_acronyms {
    $ABBREVIATIONS{$_} = 1 foreach (@_);
}

sub get_file_extensions {
    return keys %FILE_EXTENSIONS;
}

sub set_file_extensions {
    %FILE_EXTENSIONS = map {$_ => 1} @_;
}

sub add_file_extensions {
    $FILE_EXTENSIONS{$_} = 1 foreach (@_);
}

sub BEGIN {
    $ABBREVIATIONS{$_} = 1 foreach qw(
				     abb
				     abf
				     abg
				     abk
				     abs
				     abschn
				     abt
				     accel
				     adr
				     ahd
				     akk
				     al
				     ala
				     alas
				     angekl
				     angew
				     anh
				     ank
				     anm
				     antw
				     anw
				     ao
				     apl
				     apr
				     ariz
				     ark
				     ass
				     aufl
				     aug
				     aussch
				     az
				     bat
				     batt
				     battr
				     bd
				     begr
				     beif
   				    beil
				     beisp
				     bem
				     bes
				     betr
				     bez
				     bf
				     bfn
				     bg
				     bgbl
				     bhf
				     bl
				     brosch
				     bsp
				     bspw
				     btl
				     btto
				     bttr
				     bz
				     bzw
				     ca
				     calif
				     cand
				     cf
				     co
				     col
				     colo
				     conn
				     cresc
				     crt
				     ct
				     cwt
				     dat
				     decbr
				     dd
				     decresc
				     del
				     delin
				     des
				     desgl
				     dez
				     dgl
				     di
				     dim
				     dipl
				     dir
				     diss
				     do
				     doz
				     dptr
				     dr
				     dres
				     dt
				     dto
				     dtzd
				     dz
				     ebd
				     ed
				     edd
				     eidg
				     eigtl
				     einschl
				     em
				     entw
				     erdg
				     erg
				     esq
				     etc
				     ev
				     evtl
				     ew
				     exc
				     excud
				     exkl
				     expl
				     exz
				     fa
				     febr
				     fec
				     ff
				     fl
				     fla
				     fol
				     fr
				     frdl
				     frhr
				     frl
				     fud
				     ga
				     gbl
				     geb
				     gebr
				     gef
				     gefl
				     gefr
				     gegr
				     geh
				     gen
				     geogr
				     gesch
				     gest
				     get
				     gez
				     ggf
				     gr
				     grad
				     grundlag
				     habil
				     hbf
                                     hd
				     hg
				     hl
				     hll
				     hptst
				     hr
				     hrn
				     hrsg
				     hs
				     hss
				     ia
				     ib
				     ibd
				     id
				     ide
				     idg
				     ill
				     imp
				     impr
				     i
				     ii
				     iii
				     in
				     inc
				     incl
				     ind
				     inf
				     ing
				     inkl
				     inv
				     io
				     ir
				     it
				     iv
				     ix
				     jan
				     jb
				     jg
				     jgg
				     jh
				     jr
				     jun
				     kan
				    kans
				     kap
				     kart
				     kath
				     ken
				     kffr
				     kfm
				     kgl
				     kl
				     koll
				    komp
				     konj
				     kop
				     kr
				     krs
				     kt
				    kto
				     kv
				     ky
				     la
				     led
				     leg
				     lfd
				     lic
				     lim
				     liq
				     lit
				    ln
				     lnbd
				     lt
				     ltd
				     ltn
				     lz
				     ma
				     mag
				     mass
				     math
				    md
				     mdal
				     mgr
				    mhd
				     mi
				     mia
				     mich
				    mill
				     min
				     mio
				     miss
				     mlat
				     mlle
				     mlles
				     mm
				     mme
				     mmes
				     mnd
				     mo
				     mod
				     mrd
				     msgr
				     mskr
				     mss
				     mwst
				     nachf
				     nachm
				     nchf
				     nd
				     nebr
				     nev
				     nhd
				     nlat
				     nm
				     no
				     nom
				     nov
				     nr
				     nrn
				     obd
				     oblt
				     od
				     oh
				     okla
				     okt
				     op
				     oreg
				     pa
				     pag
				     part
				     pf
				     pfd
				     pinx
				     pkt
				     pl
				     plur
				     pos
				     pp
				     ppa
				     ppbd
				     prakt
				     prim
				     prof
				     prot
				     prov
				     rd
				     rec
				     ref
				     reform
				     reg
				     regt
				     resp
				     rev
				     rf
				     rfz
				     rgt
				     rhld
				     rit
				     riten
				     rp
				     s
				     sa
				     sc
				     schw
				     scil
				     sculps
				     se
				     sek
				     sel
				     sen
				     sept
				     sfr
				     sign
				     sing
				     sog
				     sost
				     sp
				     spvg
				     spvgg
				     ss
				     st
				     sta
				     stacc
				     std
				     sto
				     str
				     string
				     stud
				     sva
				     svw
				     taf
				     techn
				     ten
				     tenn
				     tex
				     theor
				     tit
				     tsd
				     uffz
				     ult
				     urspr
				     usf
				     usw
				     ut
				     v
				     var
				     vdt
				     verh
				     verm
				     vert
				     verw
				     verz
				     vgl
				     vi
				     vii
				     viii
				     vm
				     vogtl
				     vorm
				     vors
				     vp
				     vs
				     wg
				     wis
				     wwe
				     wwr
				     x
				     xi
				     xii
				     xiii
				     xiv
				     xv
				     xvi
				     xvii
				     xviii
				     xix
				     xx
                                     zb
                                     zhd
				     ziff
				     zs
				     zschr
				     ztr
				     zz
				     zzt
				     );

    $FILE_EXTENSIONS{$_} = 1 foreach qw(doc html txt ps gz zip tar pdf gif jpeg mp3 bmp tmp exe com bat
					pl java c cc vbs pod pm phtml shtml dhtml php);
}

__END__