diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/CONF.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/CONF.pm
new file mode 100644
index 0000000000000000000000000000000000000000..5a853f7b8ed5a8a49e88c1e4e2b031da144ea7a4
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/CONF.pm
@@ -0,0 +1,2379 @@
+#!/usr/bin/perl -w
+# 15.11.2005 KPG
+
+package DAASIlib::CONF;
+
+use strict;
+use warnings;
+
+use IO::Prompt;
+
+use vars qw($VERSION);
+use Log::Log4perl qw(:levels);
+
+our $VERSION = "0.7";
+our $ISDEBUG=0;
+our $ISWEB = 0;
+
+#use DAASIlib::LOG;
+### test lin
+use DAASIlib::Data;
+my $data = new DAASIlib::Data;
+use DAASIlib::Gettext;
+my $gt=new DAASIlib::Gettext;
+
+use Config::General;
+use Getopt::Std;
+use Text::Wrap;
+#use Text::Autoformat;
+use File::Basename;
+
+use constant LINELEN=> 80;
+
+sub new
+{
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ logs =>[],
+ };
+
+ bless($self , $class );
+
+ return $self;
+}
+
+sub whichConfigFile {
+ my $self = shift;
+
+ $self->{data}{configfile};
+
+}
+
+
+sub addConfig {
+ my $self = shift;
+ my ( $filename, $progpath, $etcdir, $addtoetc, $store ) = @_;
+
+ my $fullconfigfilename = $self->getPathRight($filename,
+ $progpath, $etcdir,
+ $addtoetc);
+# print "loading config $fullconfigfilename to $store\n";
+ $self->newConf( $fullconfigfilename, $self->{data}, "yes");
+}
+
+sub loadConfig {
+ my $self = shift;
+ my ( $filename, $progpath, $etcdir, $addtoetc, $progname, $isweb ) = @_;
+
+ $ISWEB = 1 if $isweb;
+
+ my %confall=();
+
+ # for any case the separator is needed before defaults are loaded:
+ $self->{data}{separator} = ',';
+
+# print "Loading configfile $filename\n";
+ $self->storeLogMessage('info', "Loading configfile $filename");
+ $self->newConf( $filename, \%confall, "no");
+
+ $self->checkOpts();
+ $self->setConfDefaults( );
+
+ $self->getOptions();
+
+
+ my $lang = $self->getOptValue('language');
+# print "lang: $lang\n";
+ if ( $lang ) {
+ $gt->setlanguage($lang);
+ my $pofile = './etc/locale/de_DE/LC_MESSAGES/'.$progname.'.po';
+ $gt->init($pofile,$lang);
+
+ $self->{gt} = $gt;
+ }
+
+ if ($self->getOptValue('debugmode') ) {
+ $self->storeLogMessage('info', "turning debugmode on");
+ $ISDEBUG = 1;
+ }
+
+ $self->formatManPage($lang);
+
+
+ if ( $self->getOptValue('printhelp') ) {
+ print @{$self->{data}{manpage}};
+ exit;
+ }
+
+# print "Helpfeature: ",$self->getOptValue('helpfeature'),"\n";
+
+ my $feature = $self->getOptValue('helpfeature');
+ if ( $feature ) {
+ if (length ($feature) == 1 ) {
+ if ( $self->{data}{usage}{$feature} ) {
+ print "Feature:\n".
+ "$self->{data}{usage}{$feature}\n";
+ }
+ else {
+ print " Unknown feature $feature\n";
+ }
+# } elsif ($feature eq "functions") {
+# $self->printFunctions;
+ } elsif ( $feature =~ /^SUM/ ){
+# print grep {/^\s\-\w /} @{$self->{data}{manpage} }[0];
+ print join "\n", sort { lc($a) cmp lc($b) } @{$self->{data}{summary} };
+ } else {
+ if ( $self->{data}{options}{$feature}{key} ) {
+ print "Feature:\n".
+ "$self->{data}{usage}{$self->{data}{options}{$feature}{key}}\n";
+ }
+ else {
+ print " Unknown feature $feature\n";
+ }
+ }
+ print "\n";
+ exit;
+ }
+
+ if ( my $value = $self->getOptValue('configfile') ) {
+ $self->{data}{configfile} = $value;
+ }
+
+ $self->{data}{progpath} = $progpath;
+ $self->{data}{etcdir} = $etcdir;
+
+ my $fullconfigfilename = $self->getPathRight($self->{data}{configfile},
+ $progpath, $etcdir,
+ $addtoetc);
+
+# print "fullconfigname: $fullconfigfilename\n";
+# exit();
+ $self->storeLogMessage('info', "Loading configfile $fullconfigfilename");
+ $self->newConf( $fullconfigfilename, $self->{data}, "yes");
+
+ $self->loadParams();
+
+ if ($self->is_debug) {
+ $self->printConf("config after processing params:");
+ }
+
+ my $errors =0;
+
+ $errors = $self->checkNotyet();
+
+ if ( ! $errors ) {
+ if ( ! $self->{data}{executetool} ) {
+ $errors = $self->checkDependencies ();
+ $errors += $self->checkAllValues ( );
+ $errors += $self->checkArgType ($errors);
+ }
+ else {
+ $errors = $self->checkValues('executetool');
+ $errors += $self->checkArgType ( $errors, 'mappingfile', 'inputfile', 'SQLfilename', 'SQLstring', 'language' );
+ }
+ }
+
+ if ($self->is_debug) {
+ $self->printConf("config after loading all:");
+ }
+
+
+ if ($errors) {
+ print "Found $errors errors\n";
+ print "\tbeware: wrong values come either from command line flags or",
+ "\n\t from the user config file $self->{data}{configfile}\n";
+ print "\tFor more information type $self->{data}{progname}.pl".
+ " -$self->{data}{options}{'printhelp'}{key}\n\n";
+ die "Aborting program\n\n";
+ }
+
+
+ my $binerrors += $self->checkPrograms();
+
+ if ($binerrors) {
+ print "Found $binerrors missing binaries\n";
+ die "Aborting program\n\n";
+ }
+
+ my $processerrors += $self->checkProcesses();
+
+ if ($processerrors) {
+ print "Found $processerrors missing processes\n";
+ die "Aborting program\n\n";
+ }
+
+# if ($self->debug()) {
+# }
+
+ $self->addFunctionParameters;
+
+
+ ## now let us modify the loglevel for Log4Perl
+ ## print "setting loglevel: $self->{data}{loglevel}\n";
+
+ if ( $self->{data}{logfile} ) {
+ $self->{data}{loglevel} = $self->setLogLevel($self->{data}{loglevel});
+ }
+
+ return $gt;
+
+}
+
+
+sub checkPrograms {
+ my $self = shift;
+ my $errors = 0;
+
+ foreach my $progName ( sort keys %{$self->{data}{checkprograms}} ) {
+ my $bin = $self->{data}{checkprograms}{$progName}{name};
+ my $must = $self->{data}{checkprograms}{$progName}{must};
+ # print "testing |$bin|\n";
+ my $sysresult = `which $bin 2>/dev/null`;
+
+ if ( $sysresult ) {
+ chomp($sysresult);
+ $self->{data}{checkprograms}{$progName}{bin} = $sysresult;
+ }
+ elsif ($must) {
+ print "ERROR: Couldn't find needed binary $bin\n";
+ $errors ++;
+ }
+ else {
+ $self->storeLogMessage('warn',
+ "Couldn't find wanted binary $bin\n");
+ }
+ }
+ return ( $errors);
+}
+
+sub checkProcesses {
+ my $self = shift;
+ my $errors = 0;
+
+ foreach my $procName ( sort keys %{$self->{data}{checkprocesses}} ) {
+ my $proc = $self->{data}{checkprocesses}{$procName}{name};
+ my $must = $self->{data}{checkprocesses}{$procName}{must};
+# print "testing $procName |$proc|\n";
+ my $sysresult = `ps aux | grep $proc 2>/dev/null`;
+
+ my @proctab = split /\n/, $sysresult;
+
+ my $is_process = 0;
+
+ foreach my $procline ( @proctab ) {
+ if ( $procline !~ /grep $proc/ ) {
+ $is_process ++;
+ }
+ }
+
+ if ( $is_process ) {
+ $self->storeLogMessage('info',
+ "Found $is_process processes of type $procName ($proc)\n")
+ if $self->is_verbose();
+ }
+ elsif ($must) {
+ print "ERROR: Couldn't find needed process $procName ($proc)\n";
+ $errors ++;
+ }
+ else {
+ $self->storeLogMessage('warn',
+ "Couldn't find needed process $procName ($proc)\n");
+ }
+ }
+ return ( $errors);
+}
+
+
+sub is_debug {
+ my $self = shift;
+ $ISDEBUG;
+}
+
+sub is_verbose {
+ my $self = shift;
+
+ $self->{data}{verbose};
+}
+
+
+sub setLogLevel {
+ my $self = shift;
+ my ( $level ) = @_;
+
+ my $loglevel;
+
+ $level = lc($level);
+
+ if ( $level eq "no" ) { $loglevel = $OFF }
+ elsif ( $level eq "all" ) { $loglevel = $ALL }
+ elsif ( $level eq "debug" ) { $loglevel = $DEBUG }
+ elsif ( $level eq "private" ) { $loglevel = $Log::Log4perl::PRIVATE_INT }
+ elsif ( $level eq "info" ) { $loglevel = $INFO }
+ elsif ( $level eq "warn" ) { $loglevel = $WARN }
+ elsif ( $level eq "error" ) { $loglevel = $ERROR }
+ elsif ( $level eq "fatal" ) { $loglevel = $FATAL }
+ else { $loglevel = $OFF }
+
+ return ($loglevel);
+}
+
+sub storeLogMessage {
+ my $self = shift;
+ my ($level, $message) = @_;
+
+ # 2008/12/22 22:04:43
+ my ( $sek, $min, $hour, $day, $mon, $year ) = localtime();
+ my $timestamp = sprintf("%4d/%02d/%02d %02d:%02d:%02d", $year+1900,
+ $mon+1, $day, $hour, $min, $sek);
+## my $timestamp = "$year/$mon/$day $hour:$min:$sek";
+
+ $level = uc($level);
+
+ push @{$self->{log}}, "$timestamp> $level: $message";
+
+}
+
+sub getLogMessages {
+ my $self = shift;
+
+ return $self->{log};
+}
+
+sub logLogMessages {
+ my $self = shift;
+ my ($logger) = @_;
+
+
+ foreach my $line ( @{$self->{log}} ) {
+ my ( $time, $type, $message ) = ( $line =~ /^([\/ :\d]+)> (\w+?): (.+)/);
+ $logger->$type($message);
+ }
+}
+
+sub printLogMessages {
+ my $self = shift;
+ my ( $praefix ) = @_;
+
+ foreach my $line ( @{$self->{log}} ) {
+### print "$line\n";
+ my ( $time,$type,$message ) = ( $line =~ /^([\/ :\d]+)> (\w+?): (.+)/);
+
+ if ( $message) {
+ if ( $type =~ /(WARN|ERROR)/ ) {
+ $message = "${praefix}$type: $message\n";
+ }
+ else {
+ $message = "${praefix}$message\n";
+ }
+ print $message;
+ }
+ }
+}
+
+
+sub newConf {
+ my $self = shift;
+ my ( $conf_file, $oldconf, $merge ) = @_;
+# print"newConf(): loading $conf_file\n";
+ my $conf = new Config::General( -file =>$conf_file, -LowerCaseNames => 0,
+# -ExtendedAccess => 1,
+ -AllowMultiOptions => 'yes',
+ -MergeDuplicateOptions => $merge,
+ -InterPolateVars => 1,
+ -DefaultConfig => $oldconf );
+
+ my %config = $conf->getall;
+
+ $self->{data} = \%config;
+
+}
+
+
+sub formatManPage {
+
+ my $self = shift;
+
+ my ( $lang ) = @_;
+
+ # Formating to a length of LINELEN
+ # the following lines are fully configurable commandline
+ # parameters definable in the config-files ...
+
+
+# my $getOptParam;
+ my ( $optName, $usage, @musts, %usage, $synopsis );
+ my ( $mustmay, $with, $synopsisstring, @manpage);
+
+ my @summary;
+
+ my $progname = $self->{data}{progname};
+ my $lenfactor= 0;
+ my $text;
+
+ $synopsis = $progname;
+
+# my $langdefault = $self->{data}{options}{language}{default};
+# my @languages = split /,\s*/, $self->{data}{options}{language}{values};
+# print "possible languages are: ".
+# $self->{data}{options}{language}{values}."\n";
+# print "language is set to: ". $self->{data}{language} ."\n"
+# if $self->{data}{language};
+
+# print "FORMATTING MANPAGE IN LANGUAGE $lang\n";
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+
+# $getOptParam .= $self->{data}{options}{$optName}{key};
+# $getOptParam .= ':' if $self->{data}{options}{$optName}{arg};
+
+# print "working on option $optName\n";
+ $text = $self->formatusage($optName, $lang);
+
+ if ( $self->{data}{options}{$optName}{key} ) {
+ $synopsisstring = "-".$self->{data}{options}{$optName}{key};
+ push @summary, $synopsisstring." (".$optName.")";
+
+ $synopsisstring .= " ".$optName
+ if $self->{data}{options}{$optName}{arg};;
+ $usage{$self->{data}{options}{$optName}{key}} = $text;
+ }
+
+ if ( $self->{data}{options}{$optName}{must} ) {
+ $mustmay = "required";
+ push ( @musts, $self->{data}{options}{$optName}{key} )
+ } else {
+ $mustmay = "optional";
+ $synopsisstring = "[ ".$synopsisstring." ]";
+ }
+
+ if ( length ($synopsis." ".$synopsisstring) - $lenfactor > LINELEN ) {
+ $lenfactor += length($synopsis);
+ $synopsis .= "\n\t".$synopsisstring;
+ } else {
+ $synopsis .= " ".$synopsisstring;
+ }
+ }
+
+
+ my $value;
+ my $key;
+ my $keykey;
+ my @additions;
+
+
+ push @manpage, "\n\nNAME\n\t$progname - $self->{data}{progshortdescr}\n";
+ push @manpage, "\nSYNOPSIS\n\t$synopsis\n";
+ push @manpage, "\n".$gt->text("DESCRIPTION")."\n",
+ $self->formatconfarray('progdescription');
+
+ push @manpage, $gt->text("OPTIONS")."\n";
+ foreach $usage (sort { "\L$a" cmp "\L$b" } keys %usage) {
+ push @manpage,$usage{$usage};
+ }
+
+
+ foreach $key (sort keys %{$self->{data}{additions}}) {
+ foreach $keykey (sort keys %{$self->{data}{additions}{$key}}) {
+ push @additions, "\t".&myformat("\t", "$self->{data}{additions}{$key}{$keykey}");
+ }
+ push @manpage, uc($key)."\n@additions\n";
+ @additions = ();
+ }
+
+ push @manpage, "SEE ALSO\n",$self->formatconfarray('seealso');
+ push @manpage, "AUTHOR\n\t$self->{data}{author}{name}, $self->{data}{author}{org}, ".
+ "$self->{data}{author}{mail}\n";
+ push @manpage,"\nVERSION\n\t$self->{data}{version}, $self->{data}{date}\n";
+ push @manpage, "\nCOPYRIGHT\n",$self->formatconfarray('copyright');
+ push @manpage, "BUGS\n",$self->formatconfarray('bugs');
+
+
+ $self->{data}{'synopsis'} = $synopsis;
+ $self->{data}{'usage'} = \%usage;
+ $self->{data}{'manpage'} = \@manpage;
+ $self->{data}{'summary'} = \@summary;
+
+}
+
+
+sub checkOpts {
+ my $self = shift;
+
+ my $getOptParam;
+
+ foreach my $optName ( sort keys %{$self->{data}{options}} ) {
+# print "Option: $optName\n";
+ $getOptParam .= $self->{data}{options}{$optName}{key};
+ $getOptParam .= ':' if $self->{data}{options}{$optName}{arg};
+ }
+ $self->{data}{'getOptParam'} = $getOptParam;
+
+
+ my $error = 0;
+ my %seen;
+ my $string = $self->{data}{getOptParam};
+
+ $string =~ s/://g;
+ while ( $string =~ /(.)/g ) {
+ if ($seen{$1} ) {
+ print "#### Error in .sys-file: \n";
+ print "\tOption key $1 is specified more than once!\n";
+ exit(-1);
+ } else {
+ $seen{$1} = 1;
+ }
+ }
+
+}
+
+
+sub formatconfarray {
+ my $self = shift;
+ my ( $token) = @_;
+ my ($key, @additions);
+
+ foreach $key (sort keys %{$self->{data}{$token}}) {
+ push @additions, "\t".&myformat("\t", "$self->{data}{$token}{$key}\n");
+ }
+
+ return ( @additions);
+}
+
+sub loadParams {
+
+ my $self = shift;
+ my $optName;
+
+ if ( $self->{data}{getOptParam} ) {
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( $self->{data}{options}{$optName}{key} &&
+ defined($self->{data}{getopts}{$self->{data}{options}{$optName}{key}}) ) {
+ $self->{data}{$optName} =
+ $self->{data}{getopts}{$self->{data}{options}{$optName}{key}};
+ }
+
+ }
+
+ }
+
+}
+
+sub checkAllValues {
+
+ my $self = shift;
+
+ my ( $optName, @values);
+ my $abortProgram = 0;
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( $self->{data}{$optName} &&
+ $self->{data}{options}{$optName}{values} ) {
+ $abortProgram += $self->checkValues($optName);
+ }
+
+ }
+ return ($abortProgram);
+}
+
+sub checkValues {
+ my $self = shift;
+ my ( $optName) = @_;
+ my ( @values);
+ my $value_is_ok = 0;
+ my $abortProgram = 0;
+
+ @values = split (/, /, $self->{data}{options}{$optName}{values} );
+ foreach my $value (@values) {
+ my $val = uc($value);
+ if ( $val =~ /^(.*)\?(.*)\?(.*)$/ ) {
+ if ( uc($self->{data}{$optName}) =~ /^$1.?$2.?$3$/ ) {
+ #print "*** Found matching value [$value] = [$self->{data}{$optName}]\n";
+ $value_is_ok = 1;
+ last;
+ }
+ } elsif ( $val =~ /^(.*)\?(.*)$/ ) {
+ if ( uc($self->{data}{$optName}) =~ /^$1.?$2$/ ) {
+ #print "*** Found matching value [$value] = [$self->{data}{$optName}]\n";
+ $value_is_ok = 1;
+ last;
+ }
+ } elsif ( $val =~ /^(.*)\*(.*)$/ ) {
+ if ( uc($self->{data}{$optName}) =~ /^$1.*$2$/ ) {
+ $value_is_ok = 1;
+ last;
+ }
+ } elsif ( $val eq uc($self->{data}{$optName})) {
+ $value_is_ok = 1;
+ last;
+ }
+ #print "Allowed Value: $value\n";
+ }
+ if (! $value_is_ok) {
+ $self->printError($optName,
+ "Wrong value \"$self->{data}{$optName}\" in",
+ "The only currently allowed values are: ".
+ join (', ', @values) );
+
+ $abortProgram += 1;
+ }
+
+ return ($abortProgram);
+}
+
+
+sub checkDependencies {
+
+ my $self = shift;
+
+ my $missingmust = 0;
+
+ $missingmust = $self->checkMusts ();
+
+ $missingmust += $self->checkRequirements ();
+
+ return($missingmust);
+}
+
+sub checkArgType {
+ my $self = shift;
+ my @optarray = @_;
+
+ my $arg_errors = 0;
+# my ($optName, $argtype, $maintype, $subtype, @additions);
+ my ($optName, $argtype );
+
+ my $old_errors;
+ if ( $optarray[0] =~ /^\d+$/ ) {
+ $old_errors = shift @optarray;
+ }
+
+ if ( ! @optarray ) {
+ @optarray = sort keys %{$self->{data}{options}};
+ }
+
+ foreach $optName ( @optarray ) {
+# print "Option: $optName: $self->{data}{options}{$optName}{argtype}\n";
+ if ( $self->{data}{$optName} && $self->{data}{options}{$optName}{argtype} ) {
+ foreach $argtype ( split (/;/, $self->{data}{options}{$optName}{argtype} )) {
+# print "checking argtype $argtype in option $optName\n";
+ if ( ($old_errors || $arg_errors) && $argtype =~ /^ask_/ ) {
+# print "#skipping ask $argtype because there is an error anyway\n";
+ }
+ else {
+ $arg_errors = $self->checkSingleArgType($optName, $argtype);
+ }
+ }
+ }
+ }
+
+ return ($arg_errors);
+
+}
+
+
+sub checkSingleArgType {
+ my $self = shift;
+ my ($optName, $argtype ) = @_;
+
+ my $arg_error= 0;
+
+ my ( $maintype, $subtype, @additions ) = split (/_/, $argtype);
+ if (! $subtype) {$subtype = "no"; }
+# print "Found argtype statement for option $optName\n";
+# print "maintype: [$maintype] subtype: [$subtype] additions: @additions\n";
+
+ if ( $maintype =~ /^filename/ ) {
+ $arg_error += $self->checkFiles ($optName, $subtype,
+ @additions);
+ }
+ elsif ( $maintype =~ /^uri/ ) {
+ $arg_error += $self->checkUri ($optName, $subtype,
+ @additions);
+ }
+ elsif ( $maintype =~ /^checkfunctions/ ) {
+ $arg_error += $self->checkFunctions ($optName, $subtype,
+ $self->{data}{$optName});
+ }
+ elsif ( $maintype =~ /^ask/ ) {
+ $arg_error += $self->askParameter ($optName, $subtype,
+ @additions);
+ }
+ elsif ( $maintype =~ /^list/ ) {
+ $arg_error += $self->checkList ($optName, $subtype,
+ $self->{data}{$optName});
+ }
+ elsif ( $maintype =~ /^char/ ) {
+ $arg_error += $self->checkChar ($optName, $subtype,
+ $self->{data}{$optName});
+ }
+ elsif ( $maintype =~ /^int/ ) {
+ $arg_error += $self->checkInt ($optName, $subtype,
+ $self->{data}{$optName});
+ }
+ elsif ( $maintype =~ /^token/ ) {
+ $arg_error += $self->checkTokens($optName, $subtype,
+ $self->{data}{$optName});
+ }
+ elsif ( $maintype =~ /^skalar/ ) {
+ if ( $subtype eq 'anyof' ) {
+ $arg_error += $self->checkAnyOf ($optName, $subtype,
+ @additions);
+
+ }
+
+ # nothing to check here ???
+ ;
+ }
+ else {
+ print "#### Error in .sys-file: \n";
+ print "\targtype ($maintype) of $optName unknown!\n";
+ exit(-1);
+ }
+ return ( $arg_error );
+
+}
+
+sub checkList {
+ my $self = shift;
+
+ my ( $optName, $list_spec, $list) = @_;;
+
+ my $list_error = 0;
+ my @specs = split (/-/, $list_spec);
+
+ my $sep = $self->{data}{separator};
+
+ # Specs specify elements of a list with following syntax:
+ # <char1><char2> where
+ # <char1> specifies if field may be empty (=optional): 'o' or not (=mandatory): 'm'
+ # <char2> specifies the fieldtype:
+ # s for string
+ # S for uppercase only string
+ # w for string containing one word
+ # c for character
+ # C for uppercase character
+ # d for decimal
+ # b for boolean (1 or 0)
+ # ##f for float
+ # ##F for Filter with format ( NOT attr == value && attr == value etc.)
+
+## print "Separator is: $self->{data}{separator}\n";
+
+ my @list = $self->carefulSplit ($self->{data}{separator}, $list);
+
+ my @listerrors;
+ my $char;
+
+ if ($#specs != $#list) {
+# print "specs: ".join('|', @specs)."\n";
+# print "list: ".join('|', @list)."\n";
+# exit();
+ push @listerrors,
+ "* ".($#list+1)." instead of ".($#specs+1).
+ " \"$sep\"-separated list elements";
+ }
+
+ for (my $i =0; $i <= $#specs; $i++ ) {
+ if ($specs[$i] =~ /^m/ && ! $list[$i] ) {
+ push @listerrors, &addError($i, $list[$i],
+ "value missing although mandatory");
+ }
+ $char = substr($specs[$i],1,1);
+## my $foundchar = 0;
+ if ( $list[$i] ) {
+ if ($char eq 'c') {
+ if ( $list[$i] !~ /^.$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "only one char expected");
+ }
+ }
+ elsif ($char eq 'C' ) {
+ if ($list[$i] !~ /^\u\w$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "one upper case char expected");
+ }
+ }
+ elsif ($char eq 'w' ) {
+ if ($list[$i] !~ /^[\w\#:,-_*]+$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "word expected");
+ }
+ }
+ elsif ($char eq 's' ) {
+ my $stringchars = '\w\s,;:@_=|.$&+*~#!?"<>%/`(){}'
+ .'\\\[\]\'\^\-';
+
+ if ( $list[$i] =~ /([^$stringchars]+)/ ) {
+ my $wrongchar= $1;
+ my $before = $`;
+ my $len = length($before);
+ if ( $len > 10 ) {
+ $before = '...'.substr($before, $len-10);
+ }
+ push @listerrors, &addError($i, $list[$i],
+ "string expected: $before->$wrongchar<-");
+ }
+ }
+ elsif ($char eq 'W') {
+ if ($list[$i] !~ /^[A-Z0-9_]+$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "upper case word expected");
+ }
+ }
+ elsif ($char eq 'd') {
+ if ( $list[$i] !~ /^\d+$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "only digits allowed");
+ }
+ }
+ elsif ($char eq 'b' ) {
+ if ( $list[$i] !~ /^[01]+$/) {
+ push @listerrors, &addError($i, $list[$i],
+ "only 1 or 0 allowed");
+ }
+ }
+ else {
+ push @listerrors, &addError($i, $list[$i],
+ "unknown list specificator $char found");
+ }
+
+ }
+
+ }
+
+ if ($#listerrors > 0) {
+ my $heading;
+ if ( lc($optName) =~ /file/ ) {
+ $heading = "Wrongly formatted line ".
+ "(file $self->{data}{$optName}) in";
+ } else {
+ $heading = "Wrong value for";
+ }
+ $self->printError($optName,$heading,
+ "found following ".($#listerrors+1)." suberrors:\n".
+ join ("\n", @listerrors) );
+ $list_error = 1;
+ }
+
+ return ($list_error);
+}
+
+
+sub addError {
+
+ my ($number, $value, $errtext) = @_;
+
+ $number++;
+ if (! $value ) { $value="";}
+ my $string = "* in $number. element of list (\"$value\"):\n\t$errtext";
+ return($string);
+}
+
+
+## carefull split that understands escaping
+sub carefulSplit {
+ my $self = shift;
+ my ( $sep, $string, $quote ) = @_;
+
+ my @array;
+# print "carefullSplit: sep: [$sep], quote: [$quote], string: $string\n";
+ my $is_to_be_reversed = ( $string =~ s/\\$sep/\376/g);
+# print "OK is_to_be_reversed = $is_to_be_reversed\n";
+### This was terrible wrong don't try again:
+# $is_to_be_reversed += ( $string =~ s/\"(.*?)$sep(.*?)\"/$1\376$2/g );
+
+ if ($quote) {
+ my $count =0;
+ while ( $string =~ /$quote(.+?)$quote/ ) {
+ my $temp = $1;
+ my $before = $`;
+ my $after = $';
+# ' #just for highlighting
+ $is_to_be_reversed += ( $temp =~ s/$sep/\376/g);
+ $string = "$before\377$temp\377$after";
+# print "### string: [$string]\n";
+ }
+
+ $string =~ s/\377/$quote/g;
+
+ }
+ @array = split (/$sep/, $string, -1);
+
+ if ($is_to_be_reversed) {
+ foreach my $element (@array) {
+ $is_to_be_reversed -= ( $element =~ s/\376/$sep/g );
+ if (! $is_to_be_reversed) {last;}
+ }
+ }
+
+ return (@array);
+
+
+}
+
+
+sub checkChar {
+ my $self = shift;
+
+ my ( $optName, $mode, $string) = @_;;
+
+ my $error = 0;
+
+ if ( $string && length($string) != 1 ) {
+ $self->printError($optName,
+ "Wrong value (\"$self->{data}{$optName}\") for",
+ "Only a single character allowed here!");
+ $error=1;
+ }
+
+ return ($error);
+
+}
+
+sub checkUri {
+ my $self = shift;
+
+ my ( $opt_name, $mode, @additions) = @_;
+
+ my $error = 0;
+ my $string = $self->{data}{$opt_name};
+# print "checking uri $string mode: $mode, additions: @additions\n";
+ if ( $string ) {
+ if ( $mode eq 'oneof' ) {
+ my $is_ok = 0;
+ foreach my $schema (@additions) {
+ if ( $string =~ /^$schema/ ) {
+ $is_ok = 1;
+ }
+ }
+ if ( ! $is_ok) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\") for",
+ "Only following Uri types are allowed here:".
+ "\n@additions");
+ $error = 1;
+ }
+ }
+ else {
+ if ( $string =~ /^file:\s*(.+)/ ) {
+ shift @additions;
+# print "starting checkfile for option $opt_name with mode exist and additions: @additions\n";
+ $error += $self->checkFiles ($opt_name, "exist", @additions);
+ # print "checked filename $1\n";
+ } elsif ( $string =~ m@^ldaps://\s*(.+)@ ) {
+ ;
+ } elsif ( $string =~ m@^ldap://\s*(.+)@ ) {
+ ;
+ } elsif ( $string =~ /^dbi:\s*(.+)/i ) {
+ ;
+ } elsif ( $string =~ /^vhost:\s*(.+)/i ) {
+ ;
+ } else {
+# print "String: $string\n";
+ if ( ! $error ) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\")"
+ ." for",
+ "Only Uri types dbi:, file: and ldap:// "
+ ."are supported!");
+ }
+ $error=1;
+ }
+ }
+ }
+
+ return ($error);
+
+}
+
+
+sub checkInt {
+ my $self = shift;
+
+ my ( $optName, $mode, $string) = @_;;
+
+ my $error = 0;
+
+ if ( $string && $string !~ /^\d+$/ ) {
+ $self->printError($optName,
+ "Wrong value \"$self->{data}{$optName}\" in",
+ "Only a number is allowed here!");
+ $error = 1;
+ }
+
+ if ( $mode && $mode ne "no" ) {
+
+ my ($min, $max ) = split (/-/, $mode);
+
+ if ( $string < $min || $string > $max ) {
+
+ $self->printError($optName,
+ "Wrong value \"$self->{data}{$optName}\" in",
+ "number must be between $min and $max!");
+ $error = 1;
+ }
+
+ }
+
+
+ return ($error);
+}
+
+sub checkTokens {
+ my $self = shift;
+
+ my ($opt_name, $subtype, $string) = @_;
+
+ $self->storeLogMessage('debug',
+ "checkTokens() with $opt_name, $subtype, $string");
+
+ if ( $string ) {
+ my @tmparray = split ( /;/, $string );
+ foreach my $temp ( @tmparray ) {
+ my ($key, $value ) = split (/=/, $temp, 2);
+ $key =~ s/^#//;
+ $self->{data}{$subtype}{$key}=$value;
+ $self->storeLogMessage('debug', "setting $subtype/$key to $value");
+ }
+}
+
+
+
+
+}
+
+
+sub checkAnyOf {
+ my $self = shift;
+
+ my ($opt_name, $subtype, @allowedvalues) = @_;
+
+ my @values = split /_/ , $self->{data}{$opt_name};
+
+# print "checking any of: @values\nallowed are @allowedvalues\n";
+ my $error = 0;
+ foreach my $val ( @values ) {
+ if (! grep /^$val$/, @allowedvalues ) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\")",
+ " feature $val is unknown");
+ $error ++;
+ }
+ }
+
+ return ($error);
+}
+
+
+sub checkFiles {
+ my $self = shift;
+
+ my ( $opt_name, $filemode, @additions) = @_;;
+
+## print "checkFiles(): optname: $opt_name, mode: $filemode, else: |@additions|\n";
+
+ my $filename = $self->{data}{$opt_name};
+
+ $filename =~ s/^file://;
+
+ if ( $additions[0] && $additions[0] eq 'subdir' ) {
+ $filename = $self->getPathRight($filename, $self->{data}{progpath},
+ $additions[1] ? "$additions[1]/" : '');
+ }
+
+ if ( $filename =~ m|^([\w./-]+)$| ) {
+ $filename = $1;
+ }
+ else {
+ die "\n####### Filename $filename contains invalid characters\n";
+ }
+
+ $self->{data}{$opt_name} = $filename;
+
+
+
+ my $file_error = 0;
+ my $filetype = 'file';
+ $filetype = 'directory' if ( @additions && $additions[0] eq 'dir' );
+
+
+# print "checkfiles mode: $filemode, type: $filetype, additions: @additions\n";
+ if ( $filemode eq "add" ) {
+ ;
+ } elsif ( $filemode eq 'exist' || $filemode eq 'ok' ) {
+
+ if ( ! -e $filename ) {
+ if ( $filemode eq 'exist' ) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\")",
+ " for this $filetype has to exist!");
+ }
+ else {
+ $self->printError($opt_name,
+ "Thus cannot check @additions in", " ");
+ }
+
+ $file_error = 1;
+ }
+
+ if ( $filetype eq 'directory' ) {
+ if ( -e $filename && ! -d $filename ) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\")",
+ " for this has to be a directory!");
+ $file_error++;
+ }
+
+ }
+
+ if (! $file_error && @additions) {
+#- print "checking Fileformat in option $opt_name\n";
+ $file_error += $self->checkFileFormat ($opt_name, @additions);
+ }
+
+ } elsif ( $filemode eq "create" ) {
+ if ( $filetype eq "directory" ) {
+ if ( ! -d $filename ) {
+ print "creating dir $filename\n";
+ mkdir $filename;
+ }
+ }
+ elsif ( $additions[0] && $additions[0] eq 'bak' ) {
+ if ( -e $filename ) {
+ my $bakfile = $filename.'bak'.$data->fileTimeStamp();
+ rename($filename, $bakfile);
+ }
+ }
+ else {
+ if ( $self->{data}{force} ) {
+ unlink $filename;
+ }
+ if ( -e $filename ) {
+ $self->printError($opt_name,
+ "Wrong value (\"$self->{data}{$opt_name}\") for",
+ "this output file must not already exist!");
+ $file_error = 1;
+ }
+ }
+ }
+
+ return($file_error);
+}
+
+
+
+sub checkFileFormat {
+
+ my $self = shift;
+ my ($opt_name, @additions) = @_;
+ my $format_error =0;
+
+ my $max_lines = $self->{data}{testmaxlines};
+ my $fp;
+ my $i;
+ my $is_list=0;
+ my @list;
+ my ($min, $max);
+
+ # print "Checking file content of $opt_name: [@additions] \n";
+
+ if ( $max_lines && ($additions[0] eq "checkfunctions" ||
+ $additions[0] eq "format" )) {
+
+ # print "Checking file format of $self->{data}{$opt_name}
+ # (first $max_lines lines)\n";
+
+ open $fp, "<$self->{data}{$opt_name}" ||
+ die "couldn't open file $self->{data}{$opt_name} for read\n";
+ $i =0;
+
+ my $last_error=0;
+ while (<$fp>) {
+ chomp;
+ if (/^\#/ || /^\s*$/ ) {next;}
+
+ if ( $additions[0] eq "format" ) {
+ $last_error += $self->checkList($opt_name, $additions[2], $_);
+ } else {
+ $last_error += $self->checkFunctions($opt_name, $additions[2], $_);
+ }
+ if ($last_error ) {
+ $format_error += $last_error;
+ print "\tline ".($i+1).": ".substr($_,0,60)." ...\n\n";
+ $last_error = 0;
+ }
+ if ($i > $max_lines) {
+ last;
+ }
+ $i++;
+ }
+
+ }
+
+ return ($format_error);
+}
+
+sub checkNotyet {
+ my $self = shift;
+
+ my $optName;
+ my $notyet;
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( $self->{data}{options}{$optName}{notyet} ) {
+ if ( $self->{data}{$optName} ) {
+ my $key = $self->{data}{options}{$optName}{key};
+ print " * Feature $optName (-$key) is not yet implemented\n";
+ $notyet++;
+ }
+ }
+ }
+
+ return($notyet);
+
+}
+
+sub checkMusts {
+ my $self = shift;
+
+ my $missingmust = 0;
+ my ( $optName);
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ my $must = $self->{data}{options}{$optName}{must};
+ my $ok = 0;
+ if ( $must ) {
+ if ( ! $self->{data}{$optName} ) {
+ if ( $must =~ /OR / ) {
+ my $musts = $must;
+ $ok = 0;
+ my @options;
+
+ while ( $musts =~ s/OR (\w+)// ) {
+ push @options, $1;
+ if ( $self->{data}{$1} ) {
+ $ok = 1;
+ }
+ }
+
+ if ( $musts ) {
+ $must = $musts;
+ }
+ elsif ( ! $ok) {
+ my $optstring;
+ if ( @options > 1 ) {
+ $optstring = "one of the options ";
+ }
+ else {
+ $optstring = "option ";
+ }
+
+ $self->printError($optName, "Missing alternative of",
+ "if this option is not set ".
+ "$optstring @options must be set");
+ $missingmust = 1;
+ }
+ }
+
+ if ( ! $ok ) {
+# print "must is nun: |$must|\n";
+ if ( $must =~ /^ASK/ ) {
+ my ($dummy, @additions) = split /_/, $must;
+ my $lang = $self->getOptValue('language');
+ my $name_lang = "name_$lang";
+ my $targetname =
+ $self->{data}{options}{$optName}{$name_lang} ?
+ $self->{data}{options}{$optName}{$name_lang} :
+ $self->{data}{options}{$optName}{name};
+# print "additions0: ".$additions[0]."\n";
+ if ( $additions[0] =~ /^ARGTYPE ?/) {
+ $additions[0] =
+ $self->{data}{options}{$optName}{argtype};
+# print "additions: ".$self->{data}{options}{$optName}{argtype}."\n";
+ }
+
+ $missingmust += $self->askParameter ($optName, $targetname,
+ @additions);
+
+ } else {
+ $self->printError($optName, "Missing",
+ "This option was neither defined in the".
+ " configuration file (token $optName)".
+ " nor as comand line flag (-".
+ $self->{data}{options}{$optName}{key}.
+ ")");
+
+ $missingmust = 1;
+ }
+ }
+ }
+ }
+ }
+ return ( $missingmust);
+}
+
+
+sub askParameter {
+ my $self = shift;
+ my ( $optName, $target, $mode ) = @_;
+
+# print "askparameter: opt: |$optName|, target: |$target|, mode: |$mode|\n";
+ my $args = '';
+ my $input;
+ my $errors = 0;
+ my $isCheck = 0;
+
+ if ( $mode eq 'p' ) {
+ $input = prompt(" Please type in $target: ", -echo=>'*' );
+ }
+ elsif ($mode =~ /^uri/ ) {
+ $input = $self->askUriParameter($optName, $target, $mode);
+ $isCheck = 1;
+ }
+ else {
+ $input = prompt(" Please type in $target: ");
+ $isCheck = 1;
+ }
+
+#??? was soll das:
+ $self->{data}{$target}= $input;
+
+ $self->{data}{$optName}= $input;
+ $errors = $self->checkSingleArgType($optName, $mode)
+ if $isCheck;
+
+ return ($errors);
+}
+
+sub askUriParameter {
+ my $self = shift;
+ my ( $optName, $target, $mode ) = @_;
+
+ my $args = '';
+ my $input;
+
+ my ( $dummy, $type) = split /_/, $mode;
+
+ my $prompt;
+ my $returnstring = '';
+ my @allowed;
+ my $default;
+
+ if ( $self->{data}{uritypes}{$type} ) {
+ print "Collecting information for "
+ .$self->{data}{uritypes}{$type}{name}."\n";
+
+ foreach my $part ( sort keys %{$self->{data}{uritypes}{$type}{parts}} ) {
+ $prompt = " Please type in ".
+ $self->{data}{uritypes}{$type}{parts}{$part}{prompt};
+
+ if ( $self->{data}{uritypes}{$type}{parts}{$part}{choose} ) {
+ @allowed = split /_/,
+ $self->{data}{uritypes}{$type}{parts}{$part}{choose};
+ $prompt .= " (allowed values: @allowed)";
+ }
+ $default = $self->{data}{uritypes}{$type}{parts}{$part}{default};
+
+ $prompt .= $default ? " [$default]: " : " []: ";
+ $input = prompt($prompt);
+ if ( ( $input ne "" || $default ) &&
+ $self->{data}{uritypes}{$type}{parts}{$part}{before} ) {
+ $returnstring .= $self->{data}{uritypes}{$type}{parts}{$part}{before};
+ }
+
+ if ( $input eq "" && $default ) {
+ $returnstring .= $default;
+ }
+ elsif ( $input eq "" &&
+ $self->{data}{uritypes}{$type}{parts}{$part}{must} ) {
+ while ( $input eq "" ) {
+ print "### You have to specify " .
+ $self->{data}{uritypes}{$type}{parts}{$part}{prompt} .
+ "!!!\n";
+ $input = prompt($prompt);
+
+ }
+ $returnstring .= $input;
+ }
+ else {
+ $returnstring .= $input;
+ }
+
+ if ( $self->{data}{uritypes}{$type}{parts}{$part}{after} ) {
+ $returnstring .= $self->{data}{uritypes}{$type}{parts}{$part}{after};
+
+ }
+
+ }
+ }
+ else {
+ print "#### Error in .sys-file: \n";
+ print "\tNo definition of uritype $type!\n";
+ exit(-1);
+
+ }
+
+ print "returning uri: \n\t$returnstring\n"
+ if $self->is_verbose();
+ return ( $returnstring );
+}
+
+
+sub checkFunctions {
+ my $self = shift;
+
+ my ( $optName, $list_spec, $list) = @_;
+ my $errors =0;
+# print "checking Functions in option $optName value: [$list]\n";
+# exit();
+ my $function;
+ while ( $list =~ s/&{2,3}(.*?)\(// ) {
+ $function = $1;
+# use Data::Dumper;
+# print '|'.Dumper($self->{data}{functions}).'|\n';
+# exit();
+ if ( ! $self->{data}{functions}{$function} ) {
+ if ( $function !~ /-to-/ && $function !~ /^x/ ) {
+ $self->printError($optName,
+ "nonexisting function |$function| referenced in",
+ "only implemented functions can be referenced!");
+ $errors++;
+ }
+ }
+
+ }
+ return ($errors);
+}
+
+
+sub checkRequirements {
+ my $self = shift;
+
+ my $reqnotfulfilled = 0;
+ my ($optName, $requirement, $reqtype, $reqcond);
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+
+ if ( $self->{data}{$optName} && $self->{data}{options}{$optName}{requires} ) {
+ foreach $requirement ( split (/;/, $self->{data}{options}{$optName}{requires} )) {
+
+
+ if ( $requirement =~ / OR / ) {
+ $reqnotfulfilled += $self->checkOrReq ($optName,
+ $requirement
+ );
+
+
+ } else {
+
+ $reqnotfulfilled += $self->checkSingleReq($optName,
+ $requirement,
+ 1 );
+ }
+ }
+ }
+ }
+
+ return ($reqnotfulfilled);
+
+}
+
+
+sub checkSingleReq {
+ my $self = shift;
+ my ($optName, $requirement, $is_printerr) = @_;
+
+ my $reqnotfulfilled=0;
+ my ( $reqtype, $reqcond ) = split (/ = /, $requirement);
+ # print "Found requirement statement [$requirement]\n";
+ # print "type: [$reqtype] condition: [$reqcond]\n";
+
+ if ( $reqtype =~ /NOT/ ) {
+ $reqnotfulfilled += $self->checkNOTReq ($optName,
+ $reqtype,
+ $reqcond,
+ $is_printerr);
+ } elsif ( $reqtype =~ /EXIST/ ) {
+ $reqnotfulfilled += $self->checkEXISTReq ($optName,
+ $reqtype,
+ $reqcond,
+ $is_printerr);
+ } elsif ( $reqtype =~ /if value/ ) {
+ $reqnotfulfilled += $self->checkIfValueReq ($optName,
+ $reqtype,
+ $reqcond,
+ $is_printerr);
+ } else {
+ $reqnotfulfilled += $self->checkSimpleReq ($optName,
+ $reqtype,
+ $reqcond,
+ $is_printerr);
+ }
+
+ return ($reqnotfulfilled);
+}
+
+sub describeOrReq {
+ my $self = shift;
+ my ($requirement) = @_;
+
+ my $text = '';
+
+ my $or = $gt->text("or");
+
+# print "describeOrReq() got: |$requirement|\n";
+ foreach my $req (split ( / OR /, $requirement )) {
+ $text .= $self->describeSingleReq($req)
+ .' '.$or.' ';
+ }
+
+ $text =~ s/ $or $//;
+
+ return ($text);
+}
+
+sub describeSingleReq {
+ my $self = shift;
+ my ($requirement) = @_;
+
+ my $text = '';
+ $requirement =~ s/^\s+//;
+# print "describeSingleReq() got: |$requirement|\n";
+
+
+ my ( $reqtype, $reqcond ) = split (/ = /, $requirement);
+
+## $reqtype =~ s/^\s*//;
+#print "single req is: |$reqtype = $reqcond| from |$requirement|\n";
+ if ( $reqtype =~ /^EXIST/ ) {
+ $text = $gt->text("option").' '.$reqcond.' '
+ . $gt->text("must be set");
+ }
+ elsif ( $reqtype eq 'NOT' ) {
+ $text = $gt->text("option").' '.$reqcond.' '
+ . $gt->text("must not be set");
+ }
+ elsif ( $reqtype eq 'if value' ) {
+ my ( $val, $cond ) = split /: /, $reqcond;
+ $text = $gt->text("if value is").' "'.$val.'" '.$gt->text("then");
+ if ( $cond =~ / \| / ) {
+ my ( $one, $two ) = split / \| /, $cond;
+ $text .= ' '.$gt->text("either").' '.$one.' '
+ .$gt->text("or").' '.$two.' '.$gt->text("must be set");
+ }
+ else {
+ $text .= ' '.$cond.' '.$gt->text("must be set");
+ }
+ }
+ else {
+ $text .= $gt->text("option").' '.$reqtype.' '
+ .$gt->text("has to contain the value").' "'.$reqcond.'"';
+ }
+# print "returning text: $text\n";
+ return $text;
+}
+
+
+sub checkOrReq {
+ my $self = shift;
+ my ( $optname, $requirement) = @_;
+ my $reqnotfulfilled = 0;
+ my ( $reqtype, $reqcond );
+ my $is_fulfilled = 0;
+ my @conds;
+
+ my @reqs = split ( / OR /, $requirement );
+
+ foreach my $req (@reqs) {
+# print "checking requirement $req\n";
+
+ ( $reqtype, $reqcond ) = split (/ = /, $req);
+# $reqnotfulfilled = $self->checkSimpleReq ($optname,
+# $reqtype,
+# $reqcond,
+# 0);
+
+ $reqnotfulfilled = $self->checkSingleReq ( $optname, $req, 0);
+ push @conds, $reqcond;
+
+ if ( ! $reqnotfulfilled ) {
+ $is_fulfilled =1;
+ }
+ }
+
+ if (! $is_fulfilled ) {
+
+ $self->printError($optname,
+ "unfulfilled requirement of",
+ "This option requires that option \"".
+ $reqtype."\" has one of the following values:".
+ " @conds ".
+ "either defined in the configuration file ".
+ "(\"$reqtype = $reqcond\") or as comand line".
+ " flag (\"-".$self->{data}{options}{$optname}{key}.
+ " $reqcond\")\n");
+ $reqnotfulfilled = 1;
+ } else {
+ $reqnotfulfilled = 0;
+ }
+
+ return ($reqnotfulfilled)
+}
+
+sub checkSimpleReq {
+ my $self = shift;
+ my ( $optName, $reqtype, $reqcond, $is_printerror) = @_;
+
+ my $reqnotfulfilled = 0;
+
+ $reqtype =~ s/^ //;
+ $reqtype =~ s/ $//;
+
+ if ( ! $self->{data}{options}{$reqtype}{key} ) {
+ print "#### Error in .sys-file: \n";
+ print "\trequirement of $optName refers to a nonexisting option [$reqtype]!\n";
+ exit(-1);
+ }
+
+# print "optname $optName, condition: $reqcond type $reqtype exists: [$self->{data}{$reqtype}]\n";
+ if ( $self->{data}{$reqtype} && $self->{data}{$reqtype} !~ /$reqcond/ ) {
+ if ( $is_printerror ) {
+ $self->printError($optName,
+ "unfulfilled requirement of",
+ "This option requires that option \"".
+ $reqtype."\" has value \"$reqcond\", ".
+ "either defined in the configuration file ".
+ "(\"$reqtype = $reqcond\") or as comand line".
+ " flag (\"-".$self->{data}{options}{$optName}{key}.
+ " $reqcond\")\n");
+ }
+ $reqnotfulfilled = 1;
+ }
+ return ($reqnotfulfilled);
+}
+
+sub checkNOTReq {
+ my $self = shift;
+ my ( $optName, $reqtype, $reqcond, $is_printerror) = @_;
+
+ my $reqnotfulfilled = 0;
+
+# print "checkNOTReq option $optName, type $reqtype, cond $reqcond\n";
+
+ if ( ! $self->{data}{options}{$reqcond}{key} ) {
+ print "#### Error in .sys-file: \n";
+ print "\trequirement of $optName refers to a nonexisting option $reqcond!\n";
+ exit(-1);
+ }
+
+ if ( $self->{data}{$reqcond} ) {
+ if ( $is_printerror ) {
+ $self->printError($optName, "Unfulfilled requirement of",
+ "If this option is set ".
+ "the option $reqcond must not be set!");
+ }
+ $reqnotfulfilled = 1;
+ }
+
+ return($reqnotfulfilled);
+}
+
+
+sub checkEXISTReq {
+ my $self = shift;
+ my ( $optName, $reqtype, $reqcond, $is_printerror) = @_;
+
+ my $reqnotfulfilled = 0;
+
+ if ( ! $self->{data}{options}{$reqcond}{key} ) {
+ print "#### Error in .sys-file: \n";
+ print "\trequirement of $optName refers to a nonexisting option $reqcond!\n";
+ exit(-1);
+ }
+
+ if ( ! $self->{data}{$reqcond} ) {
+ if ( $is_printerror ) {
+ $self->printError($optName, "Unfulfilled requirement of",
+ "If this option is set ".
+ "the option $reqcond must also be set!");
+ }
+ $reqnotfulfilled = 1;
+ }
+
+ return($reqnotfulfilled);
+}
+
+
+sub checkIfValueReq {
+
+ my $self = shift;
+ my ( $optName, $reqtype, $reqcond, $is_printerror ) = @_;
+
+ my ( $reqval, @musts ) ;
+ my $reqnotfulfilled = 0;
+ my $is_or = 0;
+ my $must;
+
+ ($reqval, $reqcond) = split (/: /, $reqcond);
+
+ if ( $reqcond =~ / \| / ) {
+ $is_or = 1;
+ @musts = split ( / \| /, $reqcond );
+ } elsif ( $reqcond =~ / \& / ) {
+ $is_or = 0;
+ @musts = split ( / \& /, $reqcond );
+ } else {
+ $is_or = 1;
+ $musts[0] = $reqcond;
+ }
+
+ my $isok = 0;
+ foreach $must (@musts) {
+ if ( ! $self->{data}{options}{$must}{key} ) {
+ print "#### Error in .sys-file: \n";
+ print "\trequirement of $optName refers to a nonexisting option $must!\n";
+ exit(-1);
+ }
+ }
+
+ if ( $self->{data}{$optName} =~ /$reqval/ ) {
+ foreach $must (@musts) {
+ if ( $self->{data}{$must} ) {
+ $isok=1;
+ if ( $is_or ) {
+ last;
+ }
+ } else {
+ $isok = 0;
+ if ( ! $is_or ) {
+ last;
+ }
+ }
+ }
+ if ( ! $isok ) {
+ $reqnotfulfilled = 1;
+ if ( $is_printerror ) {
+ my $textbit;
+ if ( $is_or ) {
+ $textbit = "one";
+ } else {
+ $textbit = "all";
+ }
+ $self->printError($optName,"unfulfilled requirement of",
+ "If its value equals \"$reqval\", ".
+ "this option requires that $textbit of ".
+ "the following options has been set ".
+ "either defined in the configuration file ".
+ "or as comand line flag: ".
+ join (', ', @musts) );
+ }
+ }
+ }
+
+ return ($reqnotfulfilled);
+}
+
+sub setConfDefaults {
+
+ my $self = shift;
+
+ my ( $optName );
+
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( !$self->{data}{$optName} && $self->{data}{options}{$optName}{default} ) {
+ $self->{data}{$optName} = $self->{data}{options}{$optName}{default};
+ }
+ }
+
+ if ( ! $self->{data}{separator} ) {
+ $self->{data}{separator} = ',';
+ }
+
+}
+
+
+sub getOptions {
+
+ my $self = shift;
+
+ my ( %opts );
+
+ if ( $self->{data}{getOptParam} ) {
+ if ( !getopts($self->{data}{getOptParam}, \%opts) ) {
+ die "\n\tUsage:\n\t" . $self->{data}{synopsis}."\n\n";
+ }
+ $self->{data}{getopts} = \%opts;
+ }
+
+}
+
+
+sub getOptValue {
+ my $self = shift;
+ my ( $optname ) = @_;
+
+ my $value = "";
+ my $key = $self->{data}{options}{$optname}{key};
+
+ if ( $key) {
+ if ( $self->{data}{getopts}{$key} ) {
+ $value = $self->{data}{getopts}{$key};
+ }
+ }
+ return ($value);
+}
+
+
+sub printConf {
+
+ my $self = shift;
+ my ( $headline ) = @_;
+
+ my ( $optName );
+
+ print "$headline\n" if $headline;
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( $self->{data}{$optName} ) {
+ print "\t$optName = $self->{data}{$optName}\n" ;
+ } else {
+ print "\t$optName = [no value set]\n";
+ }
+ }
+
+}
+
+sub getConf {
+
+ my $self = shift;
+ my ( $headline ) = @_;
+
+ my ( $optName );
+
+ my $result = '';
+
+ $result .= "$headline\n" if $headline;
+
+ foreach $optName ( sort keys %{$self->{data}{options}} ) {
+ if ( $self->{data}{$optName} ) {
+ $result .= "\t$optName = $self->{data}{$optName}\n" ;
+ } else {
+ $result .= "\t$optName = [no value set]\n";
+ }
+ }
+
+ return $result;
+}
+
+sub formatusage {
+ my $self = shift;
+
+ my ($optName, $lang) = @_;
+
+ my $text;
+ my $sep = "\t\t";
+ my $initsep;
+
+
+ if ( $self->{data}{options}{$optName}{key} ) {
+ if ( $self->{data}{options}{$optName}{arg} ) {
+ $text = "\t-" . $self->{data}{options}{$optName}{key}." "
+ . $optName."\n";
+ $initsep = "\t\t";
+# . $optName."\n\t\t";
+ } else {
+ $initsep = "\t\t";
+ $text = "\t-" . $self->{data}{options}{$optName}{key}." ["
+ . $optName."]\n";;
+#."\t";
+ }
+ }
+
+ my $desc_lang = "description_$lang";
+
+ my $description = $self->{data}{options}{$optName}{$desc_lang} ?
+ $self->{data}{options}{$optName}{$desc_lang} :
+ $self->{data}{options}{$optName}{description};
+
+ if ( $description) {
+ $description =~ s/\\n/\n/g;
+ $text .= $self->myuformat($initsep, $sep, $description."\n");
+ }
+
+ my $argtype = $self->{data}{options}{$optName}{argtype};
+ if ( $argtype && $argtype =~ /^uri_/ ) {
+ my ($uritype) = ( $argtype =~ /^uri_(.*)/ );
+
+ foreach my $part ( sort keys %{$self->{data}{uritypes}{$uritype}{parts}} ) {
+# print "uritype: $uritype part: $part\n";
+#### partdescriptions ok???
+
+ my $partdescription =
+ $self->{data}{uritypes}{$uritype}{parts}{$part}{$desc_lang} ?
+ $self->{data}{uritypes}{$uritype}{parts}{$part}{$desc_lang} :
+ $self->{data}{uritypes}{$uritype}{parts}{$part}{description};
+
+ if ( $partdescription ) {
+ $text .= $self->myuformat($initsep, $sep, $partdescription."\n");
+# print "uritype: $uritype\n";
+# print "partdescription: $partdescription\n";
+ }
+ }
+ }
+
+
+ if ( $self->{data}{options}{$optName}{experimental} ) {
+ $text .= $self->myuformat($initsep, $sep,
+ $gt->text("BEWARE: This feature is ".
+ "experimental and not yet ".
+ "fully supported")."\n");
+ }
+
+
+ $initsep = "\t\t";
+
+ if ( $self->{data}{options}{$optName}{values} ) {
+ $text .= $self->myuformat($initsep, $sep,
+ $gt->text("Possible values are").": "
+ . $self->{data}{options}{$optName}{values}
+ . "\n");
+ }
+ elsif ( $self->{data}{options}{$optName}{argtype} ) {
+ if ( $self->{data}{options}{$optName}{argtype} =~ /^filename_exist_dir/ ) {
+ $text .= $initsep.$gt->text("The directory has to exist").".\n";
+ }
+ elsif ( $self->{data}{options}{$optName}{argtype} =~ /^filename_exist/ ) {
+ $text .= $initsep.$gt->text("The file has to exist").".\n";
+ }
+ elsif ( $self->{data}{options}{$optName}{argtype} eq 'skalar' ) {
+ ;
+ }
+ else {
+ $text .= $initsep.$gt->text("The syntax will be checked").".\n";
+ }
+ }
+
+ if ( $self->{data}{options}{$optName}{requires} ) {
+ my $ismulti = 0;
+ my $reqtext;
+ my @reqs = split /;/, $self->{data}{options}{$optName}{requires};
+# if ( $optName eq 'inform' ) {
+# print "string: !$self->{data}{options}{$optName}{requires}!\n";
+# print "\@rqs: !@reqs!\n";
+# print join 'XXX', @reqs;
+# print "\ncount: $#reqs\n";
+# exit();
+# }
+
+ if ( $#reqs > 0 ) {
+ $ismulti = 1;
+ $reqtext =
+ $gt->text("The following condition(s) have to be fulfilled");
+ }
+ else {
+ $reqtext =
+ $gt->text("The following condition has to be fulfilled");
+ }
+ $reqtext .= ': ';
+# print "ori: |$self->{data}{options}{$optName}{requires}|\n";
+# my $aswellas = $gt->text("as well as");
+ my $aswellas = '';
+ my $count = 1;
+ foreach my $req ( @reqs) {
+# print "single req: |$req|\n";
+ $reqtext .= "\n";
+ $reqtext .= "$count.) " if $ismulti;
+ if ( $req =~ / OR / ) {
+ $reqtext .= $self->describeOrReq($req);
+ }
+ else {
+ $reqtext .= $self->describeSingleReq($req);
+ }
+ $reqtext .= " $aswellas " if $ismulti;
+ $count++;
+ }
+
+ $reqtext =~ s/ $aswellas $//;
+
+# if ( $optName eq 'inputuri') { print "*** inputuri req: $reqtext\n";}
+ $text .= $self->myuformat($initsep, $sep,"$reqtext\n");
+
+ }
+
+ if ( $self->{data}{options}{$optName}{must} ) {
+ if ( $self->{data}{options}{$optName}{must} =~ /^OR (.+)/ ) {
+ my $oroption = $1;
+ if ( $oroption =~ / OR / ) {
+ my $oroptiontext = $gt->text("This option or option");
+ foreach ( split / OR /, $oroption ) {
+ $oroptiontext .= " $_ (-"
+ . $self->{data}{options}{$_}{key}.")"
+ . " ".$gt->text("or")." "
+ .$gt->text("option")." ";
+ }
+ my $xx = $gt->text("or")." ". $gt->text("option");
+ $oroptiontext =~ s/ $xx $/ /;
+ $text .= $self->myuformat($initsep, $sep,
+# $gt->text("This option or option")
+# . ' ' . $oroptiontext
+ $oroptiontext
+ . $gt->text("MUST be set")."!\n");
+ }
+ else {
+ my $orkey = $self->{data}{options}{$oroption}{key};
+ $text .= $self->myuformat($initsep, $sep,
+ $gt->text("This option or option")
+ . " "
+ . $oroption . ' (-'.$orkey.') '
+ . $gt->text("MUST be set")."!\n");
+ }
+ }
+ elsif ( $self->{data}{options}{$optName}{must} =~ /^ASK/ ) {
+ $text .= $initsep.$gt->text("If not set this option will be prompted for").".\n";
+ }
+ else {
+ $text .= $initsep.$gt->text("This option MUST be set")."\n";
+ }
+ }
+
+ if ( $self->{data}{options}{$optName}{default} ) {
+ $text .= $self->myuformat($initsep, $sep,
+ $gt->text("Default is").': "'
+ . $self->{data}{options}{$optName}{default}
+ . "\"\n");
+ }
+ else {
+ $text .= $initsep.$gt->text("No default")."\n";
+ }
+
+ $text .= "\n";
+
+ if ( $text) {
+ $text =~ s/\\n/\n\t\t/g;
+# $text =~ s/\\t/\t/g;
+ $text =~ s/\\&/&/g;
+ $text =~ s/\\#/#/g;
+ $text =~ s/\\"/\"/g;
+#"
+ }
+
+ return $text;
+
+}
+
+
+### should be moved to DAASIlib::Data
+sub myformat {
+
+ my ( $sep, $line ) = @_;
+# my @lines;
+ my $wo;
+ if ( ! $ISWEB ) {
+ $Text::Wrap::columns = LINELEN - 5;
+ $line = wrap('', $sep, $line);
+ }
+# $line = autoformat $line, { left=>18, right=>70 };
+ $line .= "\n";
+ return ($line);
+
+}
+
+
+sub myuformat {
+ my $self = shift;
+ my ($initsep, $sep, $line ) = @_;
+ if ( ! $ISWEB ) {
+ $Text::Wrap::columns = LINELEN - 5;
+ $line = wrap($initsep, $sep, $line);
+ }
+# $line = autoformat $line, { left=>18, right=>70 };
+ $line .= "\n";
+ return ($line);
+}
+
+
+### From LDIF.pm may be this can be modified to be used here
+
+sub _wrap {
+ my $len=$_[1];
+ return $_[0] if length($_[0]) <= $len;
+ use integer;
+ my $l2 = $len-1;
+ my $x = (length($_[0]) - $len) / $l2;
+ my $extra = (length($_[0]) == ($l2 * $x + $len)) ? "" : "a*";
+ join("\n ",unpack("a$len" . "a$l2" x $x . $extra,$_[0]));
+}
+
+
+#sub _wrap {
+# my $self = shift;
+# my $string=$_[0];
+# my $len=$_[1];
+# my $a=(length($string)-$len>0);
+# my $b=((length($string )-$len)/($len-1));
+# join("\n ",unpack("a78" x $a . "a77" x $b . "a*",$string));
+#}
+
+sub printError {
+ my $self = shift;
+ my ( $opt_name, $heading, $errtext) = @_;
+
+ print " Error: \u$heading option \"$opt_name\":\n";
+ if ($self->is_verbose() ) {
+ print &myformat("\t",
+ "\t($self->{data}{options}{$opt_name}{description}".
+ ")\n\n");
+ }
+ print &myformat("\t","\t$errtext\n");
+
+}
+
+sub addFunctionParameters {
+ my ( $self) = shift;
+
+ my $functionconf = $self->{data}{functions};
+
+ my %locations;
+
+ foreach my $function ( keys %{$functionconf} ) {
+ my $i =1;
+ my $para = "parameter$i";
+
+ if ( $functionconf->{$function}{location} ) {
+# print "adding location ", $functionconf->{$function}{location},"\n";
+ $locations{$functionconf->{$function}{location}}++;
+ }
+
+ while ( $functionconf->{$function}{$para} ) {
+ if ( $functionconf->{$function}{$para} ne "string" ) {
+ if ( $functionconf->{$function}{$para} eq 'etcdir') {
+# print "storing $self->{data}{etcdir} to $para of function $function\n";
+ $functionconf->{$function}{$para} = $self->{data}{etcdir};
+ }
+ elsif ( $self->{data}{$functionconf->{$function}{$para}} ) {
+ $functionconf->{$function}{$para} =
+ $self->{data}{$functionconf->{$function}{$para}};
+
+ } else {
+## since we have checkfunctions now, we don't need the following:
+# print "Error: wrong functionparameter $para of \$[$function] in .sys file\n";
+# print "looked for [$functionconf->{$function}{$para}]\n";
+# print "##: [$conf->{data}{$functionconf->{$function}{$para}}]\n";
+ }
+ }
+ $i++;
+ $para = "parameter$i";
+ }
+
+ }
+
+ @{$self->{data}{functionlocations}} = keys %locations;
+
+
+# return ($functionconf);
+}
+
+sub getPathRight {
+ my $self = shift;
+ my ($fullfilename, $progpath, $subdir, $addtoetc) = @_;
+
+# print "filename: $fullfilename, progpath: $progpath, subdir: $subdir, addto: $addtoetc\n";
+
+ my $dir;
+ if ( $subdir && $subdir =~ m{^/} ) {
+ $dir = $subdir;
+ }
+ elsif ( $subdir ) {
+ $dir = "$progpath$subdir";
+ }
+ else {
+ $dir = "$progpath";
+ }
+
+ if ( ! -e $fullfilename ) {
+ my ($filename, $dirname) = fileparse($fullfilename);
+# print "######## file $fullfilename does nor exist. ($filename, $dirname)\n";
+ if ( $fullfilename =~ m{^\./(.+)} ) {
+ $fullfilename = "$progpath$1";
+ if ( ! -e $fullfilename ) {
+ $fullfilename = "$dir$filename";
+ }
+ }
+ elsif ( $dirname =~ m{^/} ) {
+ ## just do nothing and let checkFiles report an error
+ }
+ else {
+ $fullfilename = "$dir$filename";
+# print "thinking this is it: $fullfilename\n";
+ }
+ }
+
+ return ($fullfilename);
+}
+
+
+
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+DAASIlib::CONF - Perl extension for configuration management
+
+=head1 SYNOPSIS
+
+ use DAASIlib::CONF;
+
+ my $conf = new DAASIlib::CONF
+
+ $conf->loadConfig;
+
+ if ($conf->is_debug) {
+ ...
+ }
+
+ if ($conf->{data}{myoption} = "XXX" ) {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+Perl extension for configuration management based on Config::General and Getopt::Std
+the basic idea is that by an internal configuration file you can specify all
+configurable options. These options then can be configured by the user either
+via an user config file or via command line parameters.
+
+The module also creates a formated manpage from the internal configuration file.
+
+The structure of the internal configuration file is
+[text in square brackets should be replaced by your values]:
+
+
+progname = [name of your Program]
+
+version = [version number of your program]
+
+date = [Date of that version]
+
+<author>
+ name = [name of the program author]
+ org= [organisation of the program author]
+ mail = [email address of the program author]
+</author>
+
+<copyright>
+par1 = [first paragraph of your copyright statement]
+par2 = [second paragraph of your copyright statement]
+[...]
+</copyright>
+
+progshortdescr = [short description of your program]
+
+<progdescription>
+par1 = [first paragraph of your long description of your program]
+par2 = [second paragraph of your long description of your program]
+[...]
+</progdescription>
+
+<seealso>
+par1 = [first paragraph of your see also statement]
+par2 = [second paragraph of your see also statement]
+[...]
+</seealso>
+
+<bugs>
+par1 = [first paragraph of your bugs statement]
+par2 = [second paragraph of your bugs statement]
+[...]
+</bugs>
+
+<additions [heading of your first additional manpage paragraph]>
+line1 = [first formatted line of your first additional manpage paragraph]
+line2 = [second formatted line of your first additional manpage paragraph]
+line3 = " "
+[...]
+</additions>
+
+<additions [heading of your second additional manpage paragraph]>
+[...]
+</additions>
+
+<options debugmode>
+ key = [flag you want to use for setting debugmode]
+ must = [set this to 0 because option is optional]
+ description = [Text describing this option, e.g. "sets debug mode to on"]
+ arg = [set this to 0 because options needs no additional argument]
+</options>
+
+<options configfile>
+ key = [flag you want to use for setting configfile]
+ must = [set this to 0 because option is optional]
+ description = [Text describing this option, e.g. "Name of the user config
+ file with absolute or relative path. Default:
+ ./etc/dbconnector.conf" Beware to prevent long lines use \
+at the end of the line. Formatting will be donme automatically ]
+ arg = [set this tp 1 because this option needs an argument]
+ default = [set a default config file name, e.g. "./etc/dbconnector.conf"]
+</options>
+
+<options printhelp>
+ key = [flag you want to use for printing the manopage, e.g. "h"]
+ must = 0
+ description = "prints out the manpage"
+ arg = 0
+</options>
+
+#now you can define any other options for your program, using this XMLish structure
+
+<options [your optionname used in your program]>
+ key = [flag you want to use for this option]
+ must = [does the user have to set this option via command line parameter? 0/1]
+ description = [description of your option]
+ arg = [does this option need an additional argument? 0/1]
+</options>
+
+The user config file should then have the following format:
+
+ option = value
+
+All options defined in the internal config file cann be set via the user config file.
+
+e.g.:
+
+inputfile = /home/myaccount/etc/myinputfile
+
+it makes little sense to use the predefined options configfile, debugmode and printhelp
+within the user config file.
+
+
+=head2 EXPORT
+
+None by default.
+
+=head1 SEE ALSO
+
+This Module works fine with DAASIlib::HTML, DAASIlib::LDAP
+
+=head1 AUTHOR
+
+Peter Gietz, <peter.gietz@daasi.de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2005 by DAASI International GmbH
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/Convert.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/Convert.pm
new file mode 100644
index 0000000000000000000000000000000000000000..872268f704866c837150c42fcc30656c2c3c1159
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/Convert.pm
@@ -0,0 +1,2660 @@
+package DAASIlib::Convert;
+
+
+use 5.008001;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+$VERSION = "0.60";
+
+use Log::Log4perl qw(:levels);
+use Log::Log4perl::Level;
+
+my $logger = Log::Log4perl->get_logger('');
+
+use DAASIlib::DBI;
+my $libdbi = new DAASIlib::DBI;
+use DAASIlib::LDAP;
+my $libldap = new DAASIlib::LDAP;
+use DAASIlib::Data;
+my $data = new DAASIlib::Data;
+
+
+use Text::Iconv;
+#use Test::utf8;
+
+use utf8;
+
+use Encode;
+
+
+# Preloaded methods go here.
+
+
+sub new {
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ uniqueidlist => [],
+ };
+
+ bless($self , $class );
+
+ return $self;
+}
+
+
+sub init {
+
+ my $self = shift;
+ my ($codesfile, $isrealutf8, $dictionaryfile) = @_;
+ $logger->info("Init with codesfile $codesfile") if $codesfile;
+ $self->{data}{'codetabisloaded'} = 0;
+ $self->{data}{'utfcodetabisloaded'} = 0;
+ $self->{data}{'codesfile'} = $codesfile;
+ $self->{data}{'dictionaryfileisloaded'} = 0;
+ $self->{data}{'abbreviationfileisloaded'} = 0;
+ $self->{data}{'dictionaryfile'} = $dictionaryfile;
+ $self->{data}{'isrealutf8'} = $isrealutf8;
+ $self->loadiconvtable();
+
+# $self->{data}{is_UUID_module} = undef;
+# if ( ! defined( $is_UUID_module ) ) {
+ eval ("use UUID;");
+ if ( $@ ) {
+ $logger->warn("Couldn't load module UUID, Thus looking for uuidgen");
+ $self->{data}{is_UUID_module} = 0;
+ }
+ else {
+ $self->{data}{is_UUID_module} = 1;
+ }
+
+}
+
+sub is_dictionary {
+ my $self = shift;
+ return $self->{data}{'dictionaryfile'};
+
+}
+
+
+sub loadiconvtable {
+ my $self = shift;
+
+ my @array =
+ ("UTF", "ISO", "HTML",
+ "8859_1", "8859_2", "8859_3", "8859_4", "8859_5", "8859_6",
+ "8859_7", "8859_8", "8859_9",
+ "CP037", "CP038", "CP273", "CP274", "CP275", "CP278",
+ "CP280", "CP281", "CP282", "CP284", "CP285", "CP290",
+ "CP297", "CP367", "CP420", "CP423", "CP424", "CP437",
+ "CP500", "CP737", "CP775", "CP813", "CP819", "CP850",
+ "CP851", "CP852", "CP855", "CP856", "CP857", "CP860",
+ "CP861", "CP862", "CP863", "CP864", "CP865", "CP866",
+ "CP866NAV", "CP868", "CP869", "CP870", "CP871", "CP874",
+ "CP875", "CP880", "CP891", "CP903", "CP904", "CP905",
+ "CP912", "CP915", "CP916", "CP918", "CP920", "CP922",
+ "CP930", "CP932", "CP933", "CP935", "CP936", "CP937",
+ "CP939", "CP949", "CP950", "CP1004", "CP1026", "CP1046",
+ "CP1047", "CP1070", "CP1079", "CP1081", "CP1084", "CP1089",
+ "CP1124", "CP1125", "CP1129", "CP1132", "CP1133", "CP1160",
+ "CP1161", "CP1162", "CP1163", "CP1164", "CP1250", "CP1251",
+ "CP1252", "CP1253", "CP1254", "CP1255", "CP1256", "CP1257",
+ "CP1258", "CP1361", "CP10007", "CPIBM861",
+ "ISO-8859-1", "ISO-8859-2", "ISO-8859-3", "ISO-8859-4",
+ "ISO-8859-5", "ISO-8859-6", "ISO-8859-7", "ISO-8859-8",
+ "ISO-8859-9", "ISO-8859-10", "ISO-8859-11", "ISO-8859-13",
+ "ISO-8859-14", "ISO-8859-15", "ISO-8859-16",
+ "LATIN-9", "LATIN-GREEK-1", "LATIN-GREEK", "LATIN1",
+ "LATIN2", "LATIN3", "LATIN4", "LATIN5", "LATIN6", "LATIN7",
+ "LATIN8", "LATIN10", "LATINGREEK", "LATINGREEK1",
+ "T.61-8BIT", "T.61", "T.618BIT",
+ "UNICODE", "UTF-7", "UTF-8", "UTF-16", "UTF-16BE", "UTF-16LE",
+ "UTF-32", "UTF-32BE", "UTF-32LE", "UTF7", "UTF8", "UTF16",
+ "UTF16BE", "UTF16LE", "UTF32", "UTF32BE", "UTF32LE",
+ );
+
+ $self->{data}{iconvtable} = \@array;
+
+}
+
+
+sub dispatchfunction {
+ my $self = shift;
+ my ($string, $is_multival, $rh_functionconf) = @_;
+
+# $logger->debug("dispatcher loaded with: [$string], multival: $is_multival");
+# print "This is the dispatcher\n";
+ my $conv;
+ my $converted="";
+ my $function;
+ my @vals;
+
+### not really faster:
+# return("") if ( $string =~ /&&([\w-]+)\(\)/ );
+
+ if ($is_multival) {
+ @vals = split ( / \$ /, $string );
+ } else {
+ $vals[0] = $string;
+ }
+ $string = "";
+
+# print "Vals: @vals\n";
+
+ my $oristring;
+
+ foreach my $val ( @vals) {
+ if ($val =~ /&&([\w-]+)\((.*)\)/ ) {
+ $function = $1;
+ $oristring= $conv=$2;
+# print "\$function: [$function] \$converted: [$conv]\n";
+ if ( $conv ) {
+ $conv= $self->dispatchfunction($conv, $is_multival, $rh_functionconf);
+# print "sending [$conv] to function $function\n";
+ $logger->debug("sending [$conv] to function $function");
+ $conv = $self->convert($function,$conv, $rh_functionconf->{$function});
+# print "got back: |$conv|\n";
+ if ( $conv) {
+ $logger->debug("function $function returned: [$conv]");
+ }
+ else {
+ $logger->warn("call to ${function}($oristring) returned nothing!!");
+ }
+ }
+ } else {
+ #nomore function
+ $conv = $val;
+ }
+ if ( $converted) {
+ $converted = $converted . " \$ ". $conv;
+ } else {
+ $converted = $conv;
+ }
+
+ }
+
+# print "returning: [$converted]\n";
+ return($converted);
+
+}
+
+
+sub convert {
+
+ my $self = shift;
+ my ( $mode, $text, $ra_paras) = @_;
+
+ my $converted;
+ my $is_html = 0;
+ my $funcref;
+ my ($from, $to);
+
+
+# print "convert: mode: $mode, text: $text\n";
+# use Data::Dumper;
+# print Dumper($ra_paras);
+# exit();
+
+
+ # print "This is convert\n";
+ $logger->debug("convert got function $mode and text $text");
+ $text = $self->redoMakeSafe($text);
+
+ $logger->debug("convert after redomakesafe got function $mode and text $text");
+
+
+ if ( $mode =~ /^[xX]/ ) {
+# print "internal function wanted: $mode\n";
+ eval { $self->$mode() };
+ if (! $@) {
+# print "internal function $mode\n";
+ $logger->debug("convert now calls function $mode with text $text");
+ $converted = $self->$mode($text, $ra_paras);
+# print "|$mode| got back with $converted\n";
+ } else {
+# print "Ignoring unknown internal function $mode(): $@\n";
+ $logger->error("Ignoring unknown internal function $mode(): $@");
+ $converted = $text;
+ }
+ } elsif ( $mode =~ /\-to\-/i ) {
+# print "iconv function wanted\n";
+ $mode = uc($mode);
+ ($from, $to) = split (/-TO-/, $mode);
+
+ if ( $from =~ /^HTML$/ ) {
+ $text = $self->html_to_utf8($text);
+ $from = "UTF-8";
+ }
+
+ if ( $to =~ /^HTML$/ ) {
+ $is_html = 1;
+ $to = "UTF-8";
+ }
+
+ $from =~ s/^ISO$/ISO-8859-1/;
+ $to =~ s/^ISO$/ISO-8859-1/;
+ $from =~ s/^UTF$/UTF-8/;
+ $to =~ s/^UTF$/UTF-8/;
+
+ my $to_is_ok = 0;
+ my $from_is_ok = 0;
+
+ foreach my $coding (@{$self->{data}{iconvtable}}) {
+ if (!$to_is_ok && ( $to eq $coding ) ) {
+ $to_is_ok = 1;
+ }
+ if (!$from_is_ok && ( $from eq $coding ) ) {
+ $from_is_ok = 1;
+ }
+ if ($to_is_ok && $from_is_ok ) {
+ last;
+ }
+ }
+
+ if ( ! $to_is_ok || ! $from_is_ok ) {
+### TODO LOG ERROR here
+ print "unknown Iconv encoding function wanted: $from -> $to\n";
+ print "To: $to_is_ok from: $from_is_ok\n";
+ $converted = $text;
+ } else {
+# print "converting $text from $from to $to\n";
+ my $converter = Text::Iconv->new($from, $to);
+ $converter->raise_error(1);
+ eval { $converted = $converter->convert($text) };
+# $converted = $converter->convert($text);
+
+ if ( $text && !$converted ) {
+ if ($@) {
+ $@ =~ s/(.*) at [\.\/\\].*/$1/;
+ $logger->error("### Error in Iconv ($from -> $to) of [$text]: $@");
+ } else {
+ $logger->error("### unknown Error in Iconv conversion ($from -> $to) of [$text]");
+#### TODO log error here
+ }
+ $converted = $text;
+ }
+
+ if ($is_html) {
+ $converted = $self->utf8_to_html($converted);
+ }
+ }
+
+ } else {
+
+### TODO LOG ERROR here
+# print "unknown function $mode [$from] -> [$to] wanted\n";
+ $converted = $text;
+ }
+
+ return($converted);
+}
+
+sub functiongrep {
+ my $self = shift;
+ my ( $searchvalue, $searchfunction, $ra_values ) = @_;
+
+# use Data::Dumper;
+# print Dumper($ra_values);
+# exit();
+ my $is_found = 0;
+
+ foreach ( @{$ra_values} ) {
+# print "### processing value $_\n";
+ if ( $searchfunction ) {
+ if ( $self->$searchfunction($_) eq $searchvalue ) {
+ $is_found = 1;
+ last;
+ }
+ } else {
+ if ( $_ eq $searchvalue ) {
+ $is_found = 1;
+ last;
+ }
+ }
+ }
+
+ return ($is_found);
+}
+
+sub xdoesexist {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ( $string) {
+ return "TRUE";
+ }
+ return "FALSE";
+}
+
+
+sub xtrim {
+ my $self = shift;
+ my ( $string ) = @_;
+
+# print "xtrim with string [$string]\n";
+ if ( $string) {
+# $string =~ s/^ *(.*) *$/$1/;
+ $string =~ s/^\s*//;
+ $string =~ s/\s*$//;
+ }
+
+ return ($string);
+}
+
+sub xdequote {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ( $string) {
+ $string =~ s/^\s*\"//;
+ $string =~ s/\"\s*$//;
+ }
+
+ return ($string);
+}
+
+sub xremovequotes {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ( $string) {
+ $string =~ s/\"//g;
+ }
+
+ return ($string);
+}
+
+sub xcreateuid {
+ my $self = shift;
+ my ( $string ) = @_;
+
+
+ if ($string) {
+## TODO LOG notify
+# print "creating uid from [$string]\n";
+ $string = $self->xnormalize($string);
+# print "creating uid from normalized [$string]\n";
+ my @cnparts = split ( / /, $string);
+ my $uid =lc(substr($cnparts[0],0,1)).
+ lc(substr($cnparts[$#cnparts],0,4)).'01' ;
+# print "uid: $uid\n";
+ return ($uid);
+ } else {
+ return ("");
+ }
+}
+
+sub xcreaterandomstring {
+ my $self = shift;
+ my ( $string ) = @_;
+ my $randstr='';
+
+ if ($string) {
+ for ( my $i = 0; $i< length($string); $i++ ) {
+ $randstr .= $data->getrandchar();
+ }
+ return $randstr;
+ } else {
+ return ("");
+ }
+
+}
+
+sub xchecksn {
+ my $self = shift;
+ my ( $string ) = @_;
+
+
+ if ($string) {
+ return $string;
+ } else {
+ return ("Anonym");
+ }
+}
+
+sub xadd20k {
+ my $self = shift;
+ my ( $num ) = @_;
+
+ if ( $num) {
+ return (20000+$num);
+ }
+ else {
+ return ("");
+ }
+}
+
+sub xadd10g {
+ my $self = shift;
+ my ( $num ) = @_;
+
+ if ( $num) {
+ return (10000000+$num);
+ }
+ else {
+ return ("");
+ }
+}
+
+sub xboolreverse {
+ my $self = shift;
+ my ( $bool ) = @_;
+
+ if ( $bool) {
+ if ( $bool eq 'FALSE') {
+ return ('TRUE');
+ }
+ elsif ( $bool eq 'TRUE' ) {
+ return ('FALSE');
+ }
+ else {
+ $logger->error("a string supposed to be an LDAP bool, but contains neither TRUE nor FALSE, but: $bool");
+ return ('');
+ }
+ }
+ else {
+ return ('');
+ }
+}
+
+
+sub xgerman2iso3361 {
+
+ my $self = shift;
+ my ( $string ) = @_;
+
+# print "xtrim with string [$string]\n";
+ if ( $string) {
+ no warnings;
+ my %german2iso3361 = (
+"Brit. Jungferninseln" => "AI",
+"Afghanistan" => "AF",
+"Ägypten" => "EG",
+"Albanien" => "AL",
+"Algerien" => "DZ",
+"Andorra" => "AD",
+"Angola" => "AO",
+"Antigua und Barbuda" => "AG",
+"Äquatorialguinea" => "GQ",
+"Argentinien" => "AR",
+"Armenien" => "AM",
+"Aserbaidschan" => "AZ",
+"Äthiopien" => "ET",
+"Australien" => "AU",
+"Bahamas" => "BS",
+"Bahrain" => "BH",
+"Bangladesch" => "BD",
+"Barbados" => "BB",
+"Belgien" => "BE",
+"Belize" => "BZ",
+"Benin(Dahome)" => "BJ",
+"Bhutan" => "BT",
+"Birma/Myanmar" => "MM",
+"Bolivien" => "BO",
+"Bosnien und Herzegowina" => "BA",
+"Bosnien-Herzegowina" => "BA",
+"Botswana" => "BW",
+"Brasilien" => "BR",
+"Brunei Darussalam" => "BN",
+"Bulgarien" => "BG",
+"Burkina Faso" => "BF",
+"Burundi" => "BI",
+"Chile" => "CL",
+"China" => "CN",
+"China (VR)(einschl.Tibet)" => "CN",
+"Cookinseln" => "CK",
+"Costa Rica" => "CR",
+"Dänemark" => "DK",
+"Deutschland" => "DE",
+"Dominica (Winward Inseln)" => "DM",
+"Dominikanische Republik" => "DO",
+"Dschibuti" => "DJ",
+"Ecuador" => "EC",
+#"ehemalige Sowjetunion" => "",
+"El Salvador" => "SV",
+"Elfenbeinküste" => "CI",
+#"Eritrea" => "",
+"Eritrea" => "ER",
+"Estland" => "EE",
+"Fidschi-Inseln" => "FJ",
+"Finnland" => "FI",
+"Frankreich" => "FR",
+"Gabun" => "GA",
+"Gambia" => "GM",
+"Georgien" => "GE",
+"Ghana" => "GH",
+"Gibraltar" => "GI",
+"Grenada" => "GD",
+"Grenadinen (St.Vincent)" => "GD",
+"Griechenland" => "GR",
+"Guatemala" => "GT",
+"Guayana" => "GY",
+"Guinea" => "GN",
+"Guinea-Bissau" => "GW",
+"Haiti" => "HT",
+"Honduras" => "HN",
+"Hongkong" => "HK",
+"Indien" => "IN",
+"Indonesien" => "ID",
+"Irak" => "IQ",
+"Iran,Islamische Republik" => "IR",
+"Irland" => "IE",
+"Island" => "IS",
+"Israel" => "IL",
+"Italien" => "IT",
+"Jamaika" => "JM",
+"Japan" => "JP",
+"Jemen" => "YE",
+"Jordanien" => "JO",
+"Kambodscha" => "KH",
+"Kamerun" => "CM",
+"Kanada" => "CA",
+"Kap Verde" => "CV",
+"Kasachstan" => "KZ",
+"Katar" => "QA",
+"Kenia" => "KE",
+"Kirgisien" => "KG",
+"Kiribati" => "KI",
+"Kolumbien" => "CO",
+"Komoren" => "KM",
+"Kongo, Volksrepublik" => "CG",
+"Kongo (Dem.Republik)" => "CD",
+"Korea, Republik" => "KR",
+"Korea, Nord, Demokr. VR" => "KP",
+"Kroatien" => "HR",
+"Kuba" => "CU",
+"Kuwait" => "KW",
+"Laotische Dem.Volksrep." => "LA",
+"Lesotho" => "LS",
+"Lettland" => "LV",
+"Libanon" => "LB",
+"Liberia" => "LR",
+"Libyen" => "LY",
+"Liechtenstein" => "LI",
+"Litauen" => "LT",
+"Luxemburg" => "LU",
+"Madagaskar" => "MG",
+"Malawi" => "MW",
+"Malaysia" => "MY",
+"Malediven" => "MV",
+"Mali" => "ML",
+"Malta" => "MT",
+"Marokko" => "MA",
+"Marshall-Inseln" => "MH",
+"Mauretanien" => "MR",
+"Mauritius" => "MU",
+"Mazedonien(ehem.jug.Rep.)" => "MK",
+"Mazedonien" => "MK",
+"Mexiko" => "MX",
+"Mikronesien" => "FM",
+"Moldawien" => "MD",
+"Monaco" => "MC",
+"Mongolei" => "MN",
+"Mosambik" => "MZ",
+"Niederl.Antillen" => "AN",
+"Namibia" => "NA",
+"Nauru" => "NR",
+"Nepal" => "NP",
+"Neuseeland" => "NZ",
+"Nicaragua" => "NI",
+"Niederlande" => "NL",
+"Niger" => "NE",
+"Nigeria" => "NG",
+"Niue" => "NU",
+"Norwegen" => "NO",
+"Ohne Angabe" => "00",
+"Oman" => "OM",
+"Österreich" => "AT",
+"Pakistan,Islamische Rep." => "PK",
+"Pakistan" => "PK",
+"Palau" => "PW",
+"Panama" => "PA",
+"Papua-Neuguinea" => "PG",
+"Paraguay" => "PY",
+"Peru" => "PE",
+"Philippinen" => "PH",
+"Pitcairn-Inseln" => "PN",
+"Polen" => "PL",
+"Portugal" => "PT",
+"Ruanda" => "RW",
+"Rumänien" => "RO",
+"Russische Foederation" => "RU",
+"Sao Tome und Principe" => "ST",
+"Salomonen" => "SB",
+"Sambia" => "ZM",
+"San Marino" => "SM",
+"Saudi-Arabien" => "SA",
+"Schweden" => "SE",
+"Schweiz" => "CH",
+"Senegal" => "SN",
+"Serbien und Montenegro" => "CS",
+"Serbien u. Montenegro" => "CS",
+"Seychellen" => "SC",
+"Sierra Leone" => "SL",
+"Simbabwe" => "ZW",
+"Singapur" => "SG",
+"Slowakei" => "SK",
+"Slowenien" => "SI",
+"Somalia" => "SO",
+"Spanien" => "ES",
+"Sri Lanka(Ceylon)" => "LK",
+"St.Helena einschl.Ascens." => "SH",
+"St.Kitts und Nevis" => "KN",
+"Staatenlos" => "0",
+"Südafrika" => "ZA",
+"Sudan" => "SD",
+"Surinam" => "SR",
+"Swasiland" => "SZ",
+"Arabische Republ.Syrien" => "SY",
+"Tadschikistan" => "TJ",
+"Taiwan" => "TW",
+"Tansania" => "TZ",
+"Thailand" => "TH",
+"Thailand" => "TH",
+"Timor" => "TL",
+"Togo" => "TG",
+"Tonga" => "TO",
+"Trinidad und Tobago" => "TT",
+"Tschad" => "TD",
+"Tschechische Republik" => "CZ",
+"Tschechei" => "CZ",
+"Tunesien" => "TN",
+"Türkei" => "TR",
+"Turkmenien" => "TM",
+"Tuvalu" => "TV",
+"Uganda" => "UG",
+"Ukraine" => "UA",
+"Ungarn" => "HU",
+"Ungeklärt" => "0",
+"Uruguay" => "UY",
+"USA" => "US",
+"Usbekistan" => "ZU",
+"Vanuatu" => "VU",
+"Vatikanstadt" => "VA",
+"Venezuela" => "VE",
+"Vereinigte Arab. Emirate" => "AE",
+"Vereinigtes Königreich" => "GB",
+"Vietnam" => "VN",
+"Weissrussland(Belarus)" => "BY",
+"Weissrussland" => "BY",
+"Westsamoa" => "WS",
+"Zentralafrik. Republik" => "CF",
+"Zypern" => "CY",
+ );
+
+ use warnings;
+ my $iso = $german2iso3361{$string};
+
+ if ( ! $iso ) {
+ my $converter = Text::Iconv->new('UTF-8' , 'ISO-8859-1');
+# $converter->raise_error(1);
+ eval { $string = $converter->convert($string) };
+ if ($string) {
+ $iso = $german2iso3361{$string};
+ }
+ }
+
+ return($iso);
+ } else {
+ return("");
+ }
+
+# if ( $german2iso3361{$string} ) {
+# return ( $german2iso3361{$string} );
+# } else {
+# my $converter = Text::Iconv->new('UTF-8' , 'ISO-8859-1');
+# $converter->raise_error(1);
+# eval { $string = $converter->convert($string) };
+# if ( $string) {
+# if ( $german2iso3361{$string} ) {
+# return ( $german2iso3361{$string} );
+# } else {
+# $logger->error("unknown countryname $string");
+# return ("");
+# }
+# }
+# }
+# } else {
+# return("");
+# }
+}
+
+
+sub xgerman2iso3361_old {
+
+ my $self = shift;
+ my ( $string ) = @_;
+
+# print "xtrim with string [$string]\n";
+ if ( $string) {
+ no warnings;
+ my %german2iso3361 = (
+ "Afghanistan" => "AF",
+ "Albanien" => "AL",
+ "Armenien" => "AM",
+ "Arabische Republ.Syrien" => "SY",
+ "Arabische Republ. Syrien" => "SY",
+ "Arabische Republik Syrien" => "SY",
+ "Argentinien" => "AR",
+ "Ägypten" => "EG",
+ "\xc3\x84gypten" => "EG",
+ "Äthiopien" => "ET",
+ "\xc3\x84thiopien" => "ET",
+ "Benin(Dahome)" => "BJ",
+ "Benin" => "BJ",
+ "Bosnien und Herzegowina" => "BA",
+ "Bosnien-Herzegowina" => "BA",
+ "Bulgarien" => "BG",
+ "Burkina Faso" => "BF",
+ "Chile" => "CL",
+ "China (VR)(einschl.Tibet)" => "CN",
+ "Deutschland" => "DE",
+ "Ecoador" => "EC",
+ "Estland" => "EE",
+ "Frankreich" => "FR",
+ "Finnland" => "FI",
+ "Georgien" => "GE",
+ "Ghana" => "GH",
+ "Griechenland" => "GR",
+ "Indien" => "IN",
+ "Indonesien" => "ID",
+ "Irak" => "IQ",
+ "Iran,Islamische Republik" => "IR",
+ "Iran" => "IR",
+ "Irland" => "IE",
+ "Israel" => "IL",
+ "Italien" => "IT",
+ "Kambodscha" => "KH",
+ "Kamerun" => "CM",
+ "Kasachstan" => "KZ",
+ "Kenia" => "KE",
+ "Kirgisien" => "KG",
+ "Kolumbien" => "CO",
+ "Korea, Nord, Demokr. VR" => "KP",
+ "Korea, Republik" => "KR",
+ "Kroatien" => "HR",
+ "Kuba" => "CU",
+ "Lettland" => "LV",
+ "Libanon" => "LB",
+ "Litauen" => "LT",
+ "Malaysia" => "MY",
+ "Mauretanien" => "MR",
+ "Marokko" => "MA",
+ "Mazedonien" => "MK",
+ "Moldawien" => "MD",
+ "Mongolei" => "MN",
+ "Niederlande" => "NL",
+ "Ãsterreich" => "AT",
+ "Österreich" => "AT",
+ "\xc3\x96sterreich" => "AT",
+ "Pakistan,Islamische Rep." => "PK",
+ "Pakistan" => "PK",
+ "Paraguay" => "PY",
+ "Polen" => "PL",
+ "Ruanda" => "RW",
+ "Rumänien" => "RO",
+ "Rumänien" => "RO",
+ "Russische Foederation" => "RU",
+ "Schweiz" => "CH",
+ "Senegal" => "SN",
+ "Serbien und Montenegro" => "CS",
+ "Serbien" => "CS",
+ "Singapur" => "SG",
+ "Slowakai" => "SK",
+ "Slowenien" => "SI",
+ "Spanien" => "ES",
+ "Staatenlos" => "00",
+ "Syrien" => "SY",
+ "Sri Lanka(Ceylon)" => "LK",
+ "Thailand" => "TH",
+ "Tschechische Republik" => "CZ",
+ "Tunesien" => "TN",
+ "Türkei" => "TR",
+ "Türkei" => "TR",
+ "Turkmenien" => "TM",
+ "Ukraine" => "UA",
+ "Ungarn" => "HU",
+ "Usbekistan" => "UZ",
+ "Vereinigtes Königreich" => "GB",
+ "Vereinigtes Königreich" => "GB",
+ "Vietnam" => "VN",
+ "Weissrussland(Belarus)" => "BY",
+ "Weissrussland" => "BY",
+ );
+ use warnings;
+ if ( $german2iso3361{$string} ) {
+ return ( $german2iso3361{$string} );
+ } else {
+ $logger->error("unknown countryname $string");
+ return ("");
+ }
+ } else {
+ return("");
+ }
+}
+
+sub searchValue {
+ my $self = shift;
+ my ( $mapvalue, $uri, $attr, $mapattr, $searchtype, $pwtoken ) = @_;
+ my $searchedvalue="";
+
+ if ( $uri =~ /^ldap/ ) {
+ $searchedvalue=$libldap->searchValueFromLdap($attr, $mapvalue,
+ $mapattr, $uri,
+ $searchtype, $pwtoken);
+ } elsif ( $uri =~ /^dbi/ ) {
+ $searchedvalue=$libdbi->searchValueFromSql($attr, $mapvalue, $mapattr,
+ $uri, $searchtype, $pwtoken);
+ }
+
+}
+
+
+sub loadValues {
+ my $self = shift;
+ my ( $ra_list, $uri, $attr, $pwtoken ) = @_;
+ $logger->debug("Loading $attr values from $uri");
+#print "Loading values (attr $attr from $uri)\n";
+ if ( $uri =~ /^ldap/ ) {
+ $libldap->loadValuesFromLdap($ra_list, $uri, $attr, $pwtoken);
+ } elsif ( $uri =~ /^dbi/ ) {
+ $libdbi->loadValuesFromSql($ra_list, $uri, $attr, $pwtoken);
+ }
+ my $valuecount = @{$ra_list};
+ if (! $valuecount ) {
+# print "no values found\n";
+ $logger->warn("no values found");
+ }
+ else {
+# print "found $valuecount values\n";
+ $logger->debug("found $valuecount values");
+ }
+}
+
+
+sub xgeneralizedTime2date {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ my $date_str ="";
+
+ if ( $string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)Z$/ ) {
+ $date_str= "$1-$2-$3 $4:$5:$6";
+ }
+
+ return ($date_str);
+}
+
+sub xunixtimestamp2generalizedTime {
+ my $self = shift;
+ my ( $string ) = @_;
+ $string = $self->xtrim($string);
+ if ($string) {
+ my ( $sek, $min, $hour, $day, $mon, $year ) = localtime($string);
+ my $timestamp = sprintf("%4d%02d%02d%02d%02d%02dZ", $year+1900,
+ $mon+1, $day, $hour, $min, $sek);
+ return $timestamp;
+ }
+ else {
+ return '';
+ }
+}
+
+
+
+sub xdate2generalizedTime {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ my $gtime;
+
+ $string = $self->xtrim($string);
+ if ($string) {
+ my ($val, $sep, $datesep, $timesep) = split /;/, $string, 4 ;
+ $sep = ' ' if ( ! $sep || $sep eq 'BLANK');
+ $datesep = '-' if ! $datesep;
+ $timesep = ':' if ! $timesep;
+ $logger->debug("xdate2generalizedTime() sep: |$sep|, datesep: |$datesep|, timesep: |$timesep|");
+ my ($date, $time ) = split /$sep /, $val, 2;
+
+ my ($year, $month, $day) = split /$datesep/, $date;
+
+ if (! $year ) {
+ $logger->error("no year found in datastring $year");
+ $year = "";
+ }
+
+ if (! $month ) {
+ $logger->error("no month found in datastring $date");
+ $month = "";
+ }
+
+ if (! $day ) {
+ $logger->error("no day found in datastring $date");
+ $day="";
+ }
+
+ if ( $time ) {
+ my ($hour,$min,$sek) = split /$timesep/, $time;
+ $gtime = "$year$month$day$hour$min${sek}Z";
+ } else {
+ $gtime = "$year$month${day}000000Z";
+ }
+ return ($gtime);
+ } else {
+ return ("");
+ }
+
+}
+
+sub xcurrentDateAsGeneralizedTime {
+
+ my $self = shift;
+
+ my ( $sek, $min, $hour, $day, $mon, $year ) = localtime();
+ my $timestamp = sprintf("%4d%02d%02d%02d%02d%02dZ", $year+1900,
+ $mon+1, $day, $hour, $min, $sek);
+
+ return ($timestamp);
+
+}
+
+
+sub elementExists {
+ my $self = shift;
+ my ($string, @list) = @_;
+
+ my $is_found =0;
+ foreach my $tmpstr ( @list ) {
+ if ( $string eq $tmpstr ) {
+ $is_found = 1;
+ last;
+ }
+
+ }
+
+ return($is_found);
+}
+
+
+sub xcreateuuid {
+ my $self = shift;
+ my $Uuid="";
+ my $string = "";
+
+ if ( ! $self->{data}{is_UUID_module} ) {
+ $string = `uuidgen -t`;
+ if ( $string) {
+ chomp($string);
+ } else {
+ $logger->error("Couldn't create UUID");
+ }
+ } else {
+ UUID::generate($Uuid);
+ UUID::unparse($Uuid, $string);
+ }
+
+ return ($string);
+
+}
+
+sub makeRegexpSafe {
+ my $self = shift;
+ my ($string) = @_;
+
+# my $tobequoted = "\)\(\]\[\#\-\*\+\.\{\}\\\/";
+# my $tobequoted = ')(\]\[#\-*+.{}\\/';
+
+# $string =~ s!([$tobequoted])!\\$1!g;
+# foreach my $char ( split '', $tobequoted) {
+# $string =~ s!(\$char)!\\$1!g;
+# }
+
+ $string =~ s/"/\\"/g;
+ $string = quotemeta($string);
+# print "made regexpsafe: $string\n";
+ return ($string);
+}
+
+sub makeSafe {
+ my $self = shift;
+ my ($string, $char ) = @_;
+
+ if ( ! $char || $char == '#') {
+ $string =~ s/\#/SZ{FIS}/g;
+ }
+ if ( ! $char || $char == '(') {
+ $string =~ s/\(/SZ{RKA}/g;
+ }
+ if ( ! $char || $char == ')') {
+ $string =~ s/\)/SZ{RKZ}/g;
+ }
+ if ( ! $char || $char == '$') {
+ $string =~ s/\$/SZ{DOL}/g;
+ }
+
+ return ($string);
+}
+
+sub redoMakeSafe {
+ my $self = shift;
+ my ($string, $char ) = @_;
+
+ if ( ! $char || $char == '#') {
+ $string =~ s/SZ{FIS}/\#/g;
+ }
+ if ( ! $char || $char == '(') {
+ $string =~ s/SZ{RKA}/\(/g;
+ }
+ if ( ! $char || $char == ')') {
+ $string =~ s/SZ{RKZ}/\)/g;
+ }
+ if ( ! $char || $char == '$') {
+ $string =~ s/SZ{DOL}/\$/g;
+ }
+ return ($string);
+}
+
+
+
+sub xnormalize {
+ my $self = shift;
+ my ( $string ) = @_;
+ my $normalized;
+
+## both these experiments didn't work:
+# use Text::Normalize::NACO qw( naco_normalize );
+# use Unicode::Normalize 'normalize';
+# if ($string) {
+# print "normalize with string [$string]\n";
+#
+# $normalized = naco_normalize( $string );
+# $normalized = normalize('KD', $string );
+# }
+
+ if ($string) {
+# print "normalizing: [$string]\n";
+ my @chararray = split //, $string;
+
+ my $is_wait_for_next =0;
+
+ foreach my $char (@chararray) {
+# print "testing char [$char]\n";
+ if ( ord($char) > 31 && ord($char) < 127 ) {
+ $normalized .=lc($char);
+ } else {
+ if ( ord($char) == 195 ) {
+ $is_wait_for_next = 1;
+ }
+ if ($is_wait_for_next ) {
+ $is_wait_for_next = 1;
+ if (ord($char) == 128 ) { $normalized .='a'; }
+ elsif (ord($char) > 128 && ord($char) < 132 ) {
+ $normalized .='a';
+ }
+ elsif (ord($char) == 132 ) { $normalized .='ae'; }
+ elsif (ord($char) == 133 ) { $normalized .='a'; }
+ elsif (ord($char) == 134 ) { $normalized .='ae'; }
+ elsif (ord($char) == 135 ) { $normalized .='c'; }
+ elsif (ord($char) > 135 && ord($char) < 140 ) {
+ $normalized .='e';
+ }
+ elsif (ord($char) > 139 && ord($char) < 144 ) {
+ $normalized .='i';
+ }
+ elsif (ord($char) == 144 ) { $normalized .='d'; }
+ elsif (ord($char) == 145 ) { $normalized .='n'; }
+ elsif (ord($char) > 145 && ord($char) < 150 ) {
+ $normalized .='o';
+ }
+ elsif (ord($char) == 150 ) { $normalized .='oe'; }
+ elsif (ord($char) > 152 && ord($char) < 156 ) {
+ $normalized .='u';
+ }
+ elsif (ord($char) == 156 ) { $normalized .='ue'; }
+ elsif (ord($char) == 159 ) { $normalized .='ss'; }
+ elsif (ord($char) > 159 && ord($char) < 164 ) {
+ $normalized .='a';
+ }
+ elsif (ord($char) == 164 ) { $normalized .='ae'; }
+ elsif (ord($char) == 165 ) { $normalized .='a'; }
+ elsif (ord($char) == 166 ) { $normalized .='ae'; }
+ elsif (ord($char) == 167 ) { $normalized .='c'; }
+ elsif (ord($char) > 167 && ord($char) < 172 ) {
+ $normalized .='e';
+ }
+ elsif (ord($char) > 171 && ord($char) < 175 ) {
+ $normalized .='i';
+ }
+ elsif (ord($char) == 177 ) { $normalized .='n'; }
+ elsif (ord($char) > 177 && ord($char) < 182 ) {
+ $normalized .='o';
+ }
+ elsif (ord($char) == 182 ) { $normalized .='oe'; }
+ elsif (ord($char) > 184 && ord($char) < 188 ) {
+ $normalized .='u';
+ }
+ elsif (ord($char) == 188 ) { $normalized .='ue'; }
+ elsif (ord($char) == 189 ) { $normalized .='y'; }
+ elsif (ord($char) == 191 ) { $normalized .='y'; }
+ } elsif ( ord($char) == 228 ) { $normalized .='ae'; }
+ elsif ( ord($char) == 246 ) { $normalized .='oe'; }
+ elsif ( ord($char) == 252 ) { $normalized .='ue'; }
+ elsif ( ord($char) == 196 ) { $normalized .='ae'; }
+ elsif ( ord($char) == 214 ) { $normalized .='oe'; }
+ elsif ( ord($char) == 220 ) { $normalized .='ue'; }
+ elsif ( ord($char) == 223 ) { $normalized .='ss'; }
+
+# print "found non ascii char [$char] Nr. ". ord($char)."in String [$string]\n";
+ }
+ }
+
+ }
+
+# print "normalize returning: $normalized\n";
+ return ($normalized);
+
+}
+
+
+
+sub xreversename {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ my ($lastname, $givenname) = split /,/, $string;
+
+ return ("$givenname $lastname");
+
+}
+
+
+sub xdecapitalizename {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ( $string ) {
+ $string =~ s/-/ - /g;
+ my $newstring = "";
+ foreach my $namepart ( split( / /, $string, -1 ) ) {
+ if ( ! $namepart ) { next; }
+ $namepart = lc($namepart);
+ $namepart = "\u$namepart";
+ if ( $newstring ) {
+ $newstring = "$newstring ";
+ }
+ $newstring .= $namepart;
+ }
+ $newstring =~ s/ - /-/g;
+ return($newstring);
+ } else {
+ return("");
+ }
+
+}
+
+
+sub xsybase_to_utf8 {
+ my $self = shift;
+ my ( $str ) =@_;
+
+ my %converts = (
+ "\xc3" => "\xc3\x9c", # Uuml
+ "\xc1" => "\xc3\x84", # Auml
+ "\xc2" => "\xc3\x96", # Ouml
+ "\xd1" => "\xc3\xa4", # auml
+ "\xd2" => "\xc3\xb6", # ouml
+ "\xd3" => "\xc3\xbc", # uuml
+ "\xbe" => "\xc3\x9f", # szlig
+ "\xe2" => "\xc3\xa9", # eacute
+ );
+## \xe1
+## \xe3
+## \xcc
+
+ my $dontknow = '[??]';
+
+ my $retstr = '';
+ if ($str ) {
+# my @chars = unpack("U*", $str);
+ my @chars = split //, $str;
+ foreach my $c (@chars) {
+ if (ord($c) > ord('~') ) {
+# print "konvertiere $c\n";
+ if ( $converts{$c} ) {
+ $retstr .= $converts{$c};
+ }
+ else {
+ $retstr .= $dontknow;
+ $logger->error("Sybase_to_utf8 doesn't know what to do with character $c (dec. ".ord($c).") in string $str");
+ }
+ }
+ else {
+ $retstr .= $c;
+ }
+ }
+
+ return($retstr);
+ }
+ else {
+ return("");
+ }
+
+}
+
+sub xsybase_to_utf8_old {
+ my $self = shift;
+ my ( $str ) =@_;
+
+ if ($str ) {
+
+ $str =~ s/\xc3/\xc3\x9c/g; # Uuml
+ $str =~ s/\xc1/\xc3\x84/g; # Auml
+ $str =~ s/\xc2/\xc3\x96/g; # Ouml
+ $str =~ s/\xd1/\xc3\xa4/g; # auml
+ $str =~ s/\xd2/\xc3\xb6/g; # ouml
+ $str =~ s/\xd3/\xc3\xbc/g; # uuml
+ $str =~ s/\xbe/\xc3\x9f/g; # szlig
+
+ $str =~ s/\xe1/[???]/g; # eacute
+ $str =~ s/\xe2/\xc3\xa9/g; # eacute
+ $str =~ s/\xe2/[???]/g; # eacute
+# $str =~ s/\xe3/[???]/g; # eacute
+
+ if ( $str =~ /([\x7f-\xff]+)/ ) {
+### if ( $1 != \xc3
+ my $char = ord($1);
+ $logger->error("Sybase_to_utf8 doesn't know what to do with character $1 dec. ($char) in string $str");
+ $str =~ s/$1/[???]/g;
+ }
+
+# $str =~ s//\xc3\xa8/g; # egrave
+# $str =~ s/ê/\xc3\xaa/g; # ecirc
+
+
+ return($str);
+ } else {
+ return("");
+ }
+}
+
+sub html_to_utf8 {
+ my $self = shift;
+ my ( $str ) =@_;
+
+$str =~ s/ü/\xc3\xbc/ig;
+$str =~ s/ /\xc2\xa0/g;
+$str =~ s/¡/\xc2\xa1/g;
+$str =~ s/¢/\xc2\xa2/g;
+$str =~ s/£/\xc2\xa3/g;
+$str =~ s/¤/\xc2\xa4/g;
+$str =~ s/¥/\xc2\xa5/g;
+$str =~ s/¦/\xc2\xa6/g;
+$str =~ s/§/\xc2\xa7/g;
+$str =~ s/¨/\xc2\xa8/g;
+$str =~ s/©/\xc2\xa9/g;
+$str =~ s/ª/\xc2\xaa/g;
+$str =~ s/«/\xc2\xab/g;
+$str =~ s/¬/\xc2\xac/g;
+$str =~ s/­/\xc2\xad/g;
+$str =~ s/®/\xc2\xae/g;
+$str =~ s/¯/\xc2\xaf/g;
+$str =~ s/°/\xc2\xb0/g;
+$str =~ s/±/\xc2\xb1/g;
+$str =~ s/²/\xc2\xb2/g;
+$str =~ s/³/\xc2\xb3/g;
+$str =~ s/´/\xc2\xb4/g;
+$str =~ s/µ/\xc2\xb5/g;
+$str =~ s/¶/\xc2\xb6/g;
+$str =~ s/·/\xc2\xb7/g;
+$str =~ s/¸/\xc2\xb8/g;
+$str =~ s/&supl;/\xc2\xb9/g;
+$str =~ s/º/\xc2\xba/g;
+$str =~ s/»/\xc2\xbb/g;
+$str =~ s/¼/\xc2\xbc/g;
+$str =~ s/½/\xc2\xbd/g;
+$str =~ s/¾/\xc2\xbe/g;
+$str =~ s/¿/\xc2\xbf/g;
+$str =~ s/À/\xc3\x80/g;
+$str =~ s/Á/\xc3\x81/g;
+$str =~ s/Â/\xc3\x82/g;
+$str =~ s/Ã/\xc3\x83/g;
+$str =~ s/Ä/\xc3\x84/g;
+$str =~ s/Å/\xc3\x85/g;
+$str =~ s/Æ/\xc3\x86/g;
+$str =~ s/Ç/\xc3\x87/g;
+$str =~ s/È/\xc3\x88/g;
+$str =~ s/É/\xc3\x89/g;
+$str =~ s/Ê/\xc3\x8a/g;
+$str =~ s/Ë/\xc3\x8b/g;
+$str =~ s/Ì/\xc3\x8c/g;
+$str =~ s/Í/\xc3\x8d/g;
+$str =~ s/Î/\xc3\x8e/g;
+$str =~ s/Ï/\xc3\x8f/g;
+$str =~ s/Ð/\xc3\x90/g;
+$str =~ s/Ñ/\xc3\x91/g;
+$str =~ s/Ò/\xc3\x92/g;
+$str =~ s/Ó/\xc3\x93/g;
+$str =~ s/Ô/\xc3\x94/g;
+$str =~ s/Õ/\xc3\x95/g;
+$str =~ s/Ö/\xc3\x96/g;
+$str =~ s/×/\xc3\x97/g;
+$str =~ s/Ø/\xc3\x98/g;
+$str =~ s/Ù/\xc3\x99/g;
+$str =~ s/Ú/\xc3\x9a/g;
+$str =~ s/Û/\xc3\x9b/g;
+$str =~ s/Ü/\xc3\x9c/g;
+$str =~ s/Ý/\xc3\x9d/g;
+$str =~ s/Þ/\xc3\x9e/g;
+$str =~ s/ß/\xc3\x9f/g;
+$str =~ s/à/\xc3\xa0/g;
+$str =~ s/á/\xc3\xa1/g;
+$str =~ s/â/\xc3\xa2/g;
+$str =~ s/ã/\xc3\xa3/g;
+$str =~ s/ä/\xc3\xa4/g;
+$str =~ s/å/\xc3\xa5/g;
+$str =~ s/æ/\xc3\xa6/g;
+$str =~ s/ç/\xc3\xa7/g;
+$str =~ s/è/\xc3\xa8/g;
+$str =~ s/é/\xc3\xa9/g;
+$str =~ s/ê/\xc3\xaa/g;
+$str =~ s/ë/\xc3\xab/g;
+$str =~ s/ì/\xc3\xac/g;
+$str =~ s/í/\xc3\xad/g;
+$str =~ s/î/\xc3\xae/g;
+$str =~ s/ï/\xc3\xaf/g;
+$str =~ s/ð/\xc3\xb0/g;
+$str =~ s/ñ/\xc3\xb1/g;
+$str =~ s/ò/\xc3\xb2/g;
+$str =~ s/ó/\xc3\xb3/g;
+$str =~ s/ô/\xc3\xb4/g;
+$str =~ s/õ/\xc3\xb5/g;
+$str =~ s/ö/\xc3\xb6/g;
+$str =~ s/÷/\xc3\xb7/g;
+$str =~ s/ø/\xc3\xb8/g;
+$str =~ s/ù/\xc3\xb9/g;
+$str =~ s/ú/\xc3\xba/g;
+$str =~ s/û/\xc3\xbb/g;
+$str =~ s/ý/\xc3\xbd/g;
+$str =~ s/þ/\xc3\xbe/g;
+$str =~ s/ÿ/\xc3\xbf/g;
+$str =~ s/Œ/\xc5\x92/g;
+$str =~ s/œ/\xc5\x93/g;
+$str =~ s/Š/\xc5\xa0/g;
+$str =~ s/š/\xc5\xa1/g;
+$str =~ s/Ÿ/\xc5\xb8/g;
+$str =~ s/ƒ/\xc6\x92/g;
+$str =~ s/ˆ/\xcb\x86/g;
+$str =~ s/˜/\xcb\x9c/g;
+$str =~ s/–/\xe2\x80\x93/g;
+$str =~ s/—/\xe2\x80\x94/g;
+$str =~ s/‘/\xe2\x80\x98/g;
+$str =~ s/’/\xe2\x80\x99/g;
+$str =~ s/‚/\xe2\x80\x9a/g;
+$str =~ s/“/\xe2\x80\x9c/g;
+$str =~ s/”/\xe2\x80\x9d/g;
+$str =~ s/„/\xe2\x80\x9e/g;
+$str =~ s/†/\xe2\x80\xa0/g;
+$str =~ s/‡/\xe2\x80\xa1/g;
+$str =~ s/•/\xe2\x80\xa2/g;
+$str =~ s/…/\xe2\x80\xa6/g;
+$str =~ s/‰/\xe2\x80\xb0/g;
+$str =~ s/‹/\xe2\x80\xb9/g;
+$str =~ s/›/\xe2\x80\xba/g;
+$str =~ s/€/\xe2\x82\xac/g;
+$str =~ s/™/\xe2\x84\xa2/g;
+
+ return ($str);
+}
+
+
+sub utf8_to_html {
+ my $self = shift;
+ my ( $str ) =@_;
+
+$str =~ s/\xc3\xbc/ü/ig;
+$str =~ s/\xc2\xa0/ /g;
+$str =~ s/\xc2\xa1/¡/g;
+$str =~ s/\xc2\xa2/¢/g;
+$str =~ s/\xc2\xa3/£/g;
+$str =~ s/\xc2\xa4/¤/g;
+$str =~ s/\xc2\xa5/¥/g;
+$str =~ s/\xc2\xa6/¦/g;
+$str =~ s/\xc2\xa7/§/g;
+$str =~ s/\xc2\xa8/¨/g;
+$str =~ s/\xc2\xa9/©/g;
+$str =~ s/\xc2\xaa/ª/g;
+$str =~ s/\xc2\xab/«/g;
+$str =~ s/\xc2\xac/¬/g;
+$str =~ s/\xc2\xad/­/g;
+$str =~ s/\xc2\xae/®/g;
+$str =~ s/\xc2\xaf/¯/g;
+$str =~ s/\xc2\xb0/°/g;
+$str =~ s/\xc2\xb1/±/g;
+$str =~ s/\xc2\xb2/²/g;
+$str =~ s/\xc2\xb3/³/g;
+$str =~ s/\xc2\xb4/´/g;
+$str =~ s/\xc2\xb5/µ/g;
+$str =~ s/\xc2\xb6/¶/g;
+$str =~ s/\xc2\xb7/·/g;
+$str =~ s/\xc2\xb8/¸/g;
+$str =~ s/\xc2\xb9/&supl;/g;
+$str =~ s/\xc2\xba/º/g;
+$str =~ s/\xc2\xbb/»/g;
+$str =~ s/\xc2\xbc/¼/g;
+$str =~ s/\xc2\xbd/½/g;
+$str =~ s/\xc2\xbe/¾/g;
+$str =~ s/\xc2\xbf/¿/g;
+$str =~ s/\xc3\x80/À/g;
+$str =~ s/\xc3\x81/Á/g;
+$str =~ s/\xc3\x82/Â/g;
+$str =~ s/\xc3\x83/Ã/g;
+$str =~ s/\xc3\x84/Ä/g;
+$str =~ s/\xc3\x85/Å/g;
+$str =~ s/\xc3\x86/Æ/g;
+$str =~ s/\xc3\x87/Ç/g;
+$str =~ s/\xc3\x88/È/g;
+$str =~ s/\xc3\x89/É/g;
+$str =~ s/\xc3\x8a/Ê/g;
+$str =~ s/\xc3\x8b/Ë/g;
+$str =~ s/\xc3\x8c/Ì/g;
+$str =~ s/\xc3\x8d/Í/g;
+$str =~ s/\xc3\x8e/Î/g;
+$str =~ s/\xc3\x8f/Ï/g;
+$str =~ s/\xc3\x90/Ð/g;
+$str =~ s/\xc3\x91/Ñ/g;
+$str =~ s/\xc3\x92/Ò/g;
+$str =~ s/\xc3\x93/Ó/g;
+$str =~ s/\xc3\x94/Ô/g;
+$str =~ s/\xc3\x95/Õ/g;
+$str =~ s/\xc3\x96/Ö/g;
+$str =~ s/\xc3\x97/×/g;
+$str =~ s/\xc3\x98/Ø/g;
+$str =~ s/\xc3\x99/Ù/g;
+$str =~ s/\xc3\x9a/Ú/g;
+$str =~ s/\xc3\x9b/Û/g;
+$str =~ s/\xc3\x9c/Ü/g;
+$str =~ s/\xc3\x9d/Ý/g;
+$str =~ s/\xc3\x9e/Þ/g;
+$str =~ s/\xc3\x9f/ß/g;
+$str =~ s/\xc3\xa0/à/g;
+$str =~ s/\xc3\xa1/á/g;
+$str =~ s/\xc3\xa2/â/g;
+$str =~ s/\xc3\xa3/ã/g;
+$str =~ s/\xc3\xa4/ä/g;
+$str =~ s/\xc3\xa5/å/g;
+$str =~ s/\xc3\xa6/æ/g;
+$str =~ s/\xc3\xa7/ç/g;
+$str =~ s/\xc3\xa8/è/g;
+$str =~ s/\xc3\xa9/é/g;
+$str =~ s/\xc3\xaa/ê/g;
+$str =~ s/\xc3\xab/ë/g;
+$str =~ s/\xc3\xac/ì/g;
+$str =~ s/\xc3\xad/í/g;
+$str =~ s/\xc3\xae/î/g;
+$str =~ s/\xc3\xaf/ï/g;
+$str =~ s/\xc3\xb0/ð/g;
+$str =~ s/\xc3\xb1/ñ/g;
+$str =~ s/\xc3\xb2/ò/g;
+$str =~ s/\xc3\xb3/ó/g;
+$str =~ s/\xc3\xb4/ô/g;
+$str =~ s/\xc3\xb5/õ/g;
+$str =~ s/\xc3\xb6/ö/g;
+$str =~ s/\xc3\xb7/÷/g;
+$str =~ s/\xc3\xb8/ø/g;
+$str =~ s/\xc3\xb9/ù/g;
+$str =~ s/\xc3\xba/ú/g;
+$str =~ s/\xc3\xbb/û/g;
+$str =~ s/\xc3\xbd/ý/g;
+$str =~ s/\xc3\xbe/þ/g;
+$str =~ s/\xc3\xbf/ÿ/g;
+$str =~ s/\xc5\x92/Œ/g;
+$str =~ s/\xc5\x93/œ/g;
+$str =~ s/\xc5\xa0/Š/g;
+$str =~ s/\xc5\xa1/š/g;
+$str =~ s/\xc5\xb8/Ÿ/g;
+$str =~ s/\xc6\x92/ƒ/g;
+$str =~ s/\xcb\x86/ˆ/g;
+$str =~ s/\xcb\x9c/˜/g;
+$str =~ s/\xe2\x80\x93/–/g;
+$str =~ s/\xe2\x80\x94/—/g;
+$str =~ s/\xe2\x80\x98/‘/g;
+$str =~ s/\xe2\x80\x99/’/g;
+$str =~ s/\xe2\x80\x9a/‚/g;
+$str =~ s/\xe2\x80\x9c/“/g;
+$str =~ s/\xe2\x80\x9d/”/g;
+$str =~ s/\xe2\x80\x9e/„/g;
+$str =~ s/\xe2\x80\xa0/†/g;
+$str =~ s/\xe2\x80\xa1/‡/g;
+$str =~ s/\xe2\x80\xa2/•/g;
+$str =~ s/\xe2\x80\xa6/…/g;
+$str =~ s/\xe2\x80\xb0/‰/g;
+$str =~ s/\xe2\x80\xb9/‹/g;
+$str =~ s/\xe2\x80\xba/›/g;
+$str =~ s/\xe2\x82\xac/€/g;
+$str =~ s/\xe2\x84\xa2/™/g;
+
+ return($str);
+}
+
+
+sub utf8_to_ascii {
+ my $self = shift;
+
+ my ( $str ) =@_;
+ my $ori = $str;
+# print "utf8_to_ascii() got |$str|\n";
+
+$str =~ s/\xc3\x80/A/g;
+$str =~ s/\xc3\x81/A/g;
+$str =~ s/\xc3\x82/A/g;
+$str =~ s/\xc3\x83/A/g;
+$str =~ s/\xc3\x84/A/g;
+$str =~ s/\xc3\x85/A/g;
+$str =~ s/\xc3\x87/C/g;
+$str =~ s/\xc3\x88/E/g;
+$str =~ s/\xc3\x89/E/g;
+$str =~ s/\xc3\x8a/E/g;
+$str =~ s/\xc3\x8b/E/g;
+$str =~ s/\xc3\x8c/I/g;
+$str =~ s/\xc3\x8d/I/g;
+$str =~ s/\xc3\x8e/I/g;
+$str =~ s/\xc3\x8f/I/g;
+$str =~ s/\xc3\x91/N/g;
+$str =~ s/\xc3\x92/O/g;
+$str =~ s/\xc3\x93/O/g;
+$str =~ s/\xc3\x94/O/g;
+$str =~ s/\xc3\x95/O/g;
+$str =~ s/\xc3\x96/O/g;
+$str =~ s/\xc3\x98/O/g;
+$str =~ s/\xc3\x99/U/g;
+$str =~ s/\xc3\x9a/U/g;
+$str =~ s/\xc3\x9b/U/g;
+$str =~ s/\xc3\x9c/U/g;
+$str =~ s/\xc3\x9d/Y/g;
+$str =~ s/\xc3\xa0/a/g;
+$str =~ s/\xc3\xa1/a/g;
+$str =~ s/\xc3\xa2/a/g;
+$str =~ s/\xc3\xa3/a/g;
+$str =~ s/\xc3\xa4/a/g;
+$str =~ s/\xc3\xa5/a/g;
+$str =~ s/\xc3\xa7/c/g;
+$str =~ s/\xc3\xa8/e/g;
+$str =~ s/\xc3\xa9/e/g;
+$str =~ s/\xc3\xaa/e/g;
+$str =~ s/\xc3\xab/e/g;
+$str =~ s/\xc3\xac/i/g;
+$str =~ s/\xc3\xad/i/g;
+$str =~ s/\xc3\xae/i/g;
+$str =~ s/\xc3\xaf/i/g;
+$str =~ s/\xc3\xb1/n/g;
+$str =~ s/\xc3\xb2/o/g;
+$str =~ s/\xc3\xb3/o/g;
+$str =~ s/\xc3\xb4/o/g;
+$str =~ s/\xc3\xb5/o/g;
+$str =~ s/\xc3\xb6/o/g;
+$str =~ s/\xc3\xb8/o/g;
+$str =~ s/\xc3\xb9/u/g;
+$str =~ s/\xc3\xba/u/g;
+$str =~ s/\xc3\xbb/u/g;
+$str =~ s/\xc3\xbc/u/g;
+$str =~ s/\xc3\xbd/y/g;
+$str =~ s/\xc3\xbf/y/g;
+$str =~ s/\xc4\x80/A/g;
+$str =~ s/\xc4\x81/a/g;
+$str =~ s/\xc4\x82/A/g;
+$str =~ s/\xc4\x83/a/g;
+$str =~ s/\xc4\x84/A/g;
+$str =~ s/\xc4\x85/a/g;
+$str =~ s/\xc4\x86/C/g;
+$str =~ s/\xc4\x87/c/g;
+$str =~ s/\xc4\x88/C/g;
+$str =~ s/\xc4\x89/c/g;
+$str =~ s/\xc4\x8a/C/g;
+$str =~ s/\xc4\x8b/c/g;
+$str =~ s/\xc4\x8c/C/g;
+$str =~ s/\xc4\x8d/c/g;
+$str =~ s/\xc4\x8e/D/g;
+$str =~ s/\xc4\x8f/d/g;
+$str =~ s/\xc4\x90/D/g;
+$str =~ s/\xc4\x91/d/g;
+$str =~ s/\xc4\x92/E/g;
+$str =~ s/\xc4\x93/e/g;
+$str =~ s/\xc4\x94/E/g;
+$str =~ s/\xc4\x95/e/g;
+$str =~ s/\xc4\x96/E/g;
+$str =~ s/\xc4\x97/e/g;
+$str =~ s/\xc4\x98/E/g;
+$str =~ s/\xc4\x99/e/g;
+$str =~ s/\xc4\x9a/E/g;
+$str =~ s/\xc4\x9b/e/g;
+$str =~ s/\xc4\x9c/G/g;
+$str =~ s/\xc4\x9d/g/g;
+$str =~ s/\xc4\x9e/G/g;
+$str =~ s/\xc4\x9f/g/g;
+$str =~ s/\xc4\xa0/G/g;
+$str =~ s/\xc4\xa1/g/g;
+$str =~ s/\xc4\xa2/G/g;
+$str =~ s/\xc4\xa3/g/g;
+$str =~ s/\xc4\xa4/H/g;
+$str =~ s/\xc4\xa5/h/g;
+$str =~ s/\xc4\xa6/H/g;
+$str =~ s/\xc4\xa7/h/g;
+$str =~ s/\xc4\xa8/I/g;
+$str =~ s/\xc4\xa9/i/g;
+$str =~ s/\xc4\xaa/I/g;
+$str =~ s/\xc4\xab/i/g;
+$str =~ s/\xc4\xac/I/g;
+$str =~ s/\xc4\xad/i/g;
+$str =~ s/\xc4\xae/I/g;
+$str =~ s/\xc4\xaf/i/g;
+$str =~ s/\xc4\xb0/I/g;
+$str =~ s/\xc4\xb4/J/g;
+$str =~ s/\xc4\xb5/j/g;
+$str =~ s/\xc4\xb6/K/g;
+$str =~ s/\xc4\xb7/k/g;
+$str =~ s/\xc4\xb9/L/g;
+$str =~ s/\xc4\xba/l/g;
+$str =~ s/\xc4\xbb/L/g;
+$str =~ s/\xc4\xbc/l/g;
+$str =~ s/\xc4\xbd/L/g;
+$str =~ s/\xc4\xbe/l/g;
+$str =~ s/\xc4\xbf/L/g;
+$str =~ s/\xc5\x80/l/g;
+$str =~ s/\xc5\x81/L/g;
+$str =~ s/\xc5\x82/l/g;
+$str =~ s/\xc5\x83/N/g;
+$str =~ s/\xc5\x84/n/g;
+$str =~ s/\xc5\x85/N/g;
+$str =~ s/\xc5\x86/n/g;
+$str =~ s/\xc5\x87/N/g;
+$str =~ s/\xc5\x88/n/g;
+$str =~ s/\xc5\x89/n/g;
+$str =~ s/\xc5\x8c/O/g;
+$str =~ s/\xc5\x8d/o/g;
+$str =~ s/\xc5\x8e/O/g;
+$str =~ s/\xc5\x8f/o/g;
+$str =~ s/\xc5\x90/O/g;
+$str =~ s/\xc5\x91/o/g;
+$str =~ s/\xc5\x94/R/g;
+$str =~ s/\xc5\x95/r/g;
+$str =~ s/\xc5\x96/R/g;
+$str =~ s/\xc5\x97/r/g;
+$str =~ s/\xc5\x98/R/g;
+$str =~ s/\xc5\x99/r/g;
+$str =~ s/\xc5\x9a/S/g;
+$str =~ s/\xc5\x9b/s/g;
+$str =~ s/\xc5\x9c/S/g;
+$str =~ s/\xc5\x9d/s/g;
+$str =~ s/\xc5\x9e/S/g;
+$str =~ s/\xc5\x9f/s/g;
+$str =~ s/\xc5\xa0/S/g;
+$str =~ s/\xc5\xa1/s/g;
+$str =~ s/\xc5\xa2/T/g;
+$str =~ s/\xc5\xa3/t/g;
+$str =~ s/\xc5\xa4/T/g;
+$str =~ s/\xc5\xa5/t/g;
+$str =~ s/\xc5\xa6/T/g;
+$str =~ s/\xc5\xa7/t/g;
+$str =~ s/\xc5\xa8/U/g;
+$str =~ s/\xc5\xa9/u/g;
+$str =~ s/\xc5\xaa/U/g;
+$str =~ s/\xc5\xab/u/g;
+$str =~ s/\xc5\xac/U/g;
+$str =~ s/\xc5\xad/u/g;
+$str =~ s/\xc5\xae/U/g;
+$str =~ s/\xc5\xaf/u/g;
+$str =~ s/\xc5\xb0/U/g;
+$str =~ s/\xc5\xb1/u/g;
+$str =~ s/\xc5\xb2/U/g;
+$str =~ s/\xc5\xb3/u/g;
+$str =~ s/\xc5\xb4/W/g;
+$str =~ s/\xc5\xb5/w/g;
+$str =~ s/\xc5\xb6/Y/g;
+$str =~ s/\xc5\xb7/y/g;
+$str =~ s/\xc5\xb8/Y/g;
+$str =~ s/\xc5\xb9/Z/g;
+$str =~ s/\xc5\xba/z/g;
+$str =~ s/\xc5\xbb/Z/g;
+$str =~ s/\xc5\xbc/z/g;
+$str =~ s/\xc5\xbd/Z/g;
+$str =~ s/\xc5\xbe/z/g;
+$str =~ s/\xc6\x80/b/g;
+$str =~ s/\xc6\x81/B/g;
+$str =~ s/\xc6\x82/B/g;
+$str =~ s/\xc6\x83/b/g;
+$str =~ s/\xc6\x87/C/g;
+$str =~ s/\xc6\x88/c/g;
+$str =~ s/\xc6\x8a/D/g;
+$str =~ s/\xc6\x8b/D/g;
+$str =~ s/\xc6\x8c/d/g;
+$str =~ s/\xc6\x91/F/g;
+$str =~ s/\xc6\x92/f/g;
+$str =~ s/\xc6\x93/G/g;
+$str =~ s/\xc6\x97/I/g;
+$str =~ s/\xc6\x98/K/g;
+$str =~ s/\xc6\x99/k/g;
+$str =~ s/\xc6\x9a/l/g;
+$str =~ s/\xc6\x9d/N/g;
+$str =~ s/\xc6\x9e/n/g;
+$str =~ s/\xc6\x9f/O/g;
+$str =~ s/\xc6\xa0/O/g;
+$str =~ s/\xc6\xa1/o/g;
+$str =~ s/\xc6\xa4/P/g;
+$str =~ s/\xc6\xa5/p/g;
+$str =~ s/\xc6\xab/t/g;
+$str =~ s/\xc6\xac/T/g;
+$str =~ s/\xc6\xad/t/g;
+$str =~ s/\xc6\xae/T/g;
+$str =~ s/\xc6\xaf/U/g;
+$str =~ s/\xc6\xb0/u/g;
+$str =~ s/\xc6\xb2/V/g;
+$str =~ s/\xc6\xb3/Y/g;
+$str =~ s/\xc6\xb4/y/g;
+$str =~ s/\xc6\xb5/Z/g;
+$str =~ s/\xc6\xb6/z/g;
+$str =~ s/\xc7\x85/D/g;
+$str =~ s/\xc7\x88/L/g;
+$str =~ s/\xc7\x8b/N/g;
+$str =~ s/\xc7\x8d/A/g;
+$str =~ s/\xc7\x8e/a/g;
+$str =~ s/\xc7\x8f/I/g;
+$str =~ s/\xc7\x90/i/g;
+$str =~ s/\xc7\x91/O/g;
+$str =~ s/\xc7\x92/o/g;
+$str =~ s/\xc7\x93/U/g;
+$str =~ s/\xc7\x94/u/g;
+$str =~ s/\xc7\x95/U/g;
+$str =~ s/\xc7\x96/u/g;
+$str =~ s/\xc7\x97/U/g;
+$str =~ s/\xc7\x98/u/g;
+$str =~ s/\xc7\x99/U/g;
+$str =~ s/\xc7\x9a/u/g;
+$str =~ s/\xc7\x9b/U/g;
+$str =~ s/\xc7\x9c/u/g;
+$str =~ s/\xc7\x9e/A/g;
+$str =~ s/\xc7\x9f/a/g;
+$str =~ s/\xc7\xa0/A/g;
+$str =~ s/\xc7\xa1/a/g;
+$str =~ s/\xc7\xa4/G/g;
+$str =~ s/\xc7\xa5/g/g;
+$str =~ s/\xc7\xa6/G/g;
+$str =~ s/\xc7\xa7/g/g;
+$str =~ s/\xc7\xa8/K/g;
+$str =~ s/\xc7\xa9/k/g;
+$str =~ s/\xc7\xaa/O/g;
+$str =~ s/\xc7\xab/o/g;
+$str =~ s/\xc7\xac/O/g;
+$str =~ s/\xc7\xad/o/g;
+$str =~ s/\xc7\xb0/j/g;
+$str =~ s/\xc7\xb2/D/g;
+$str =~ s/\xc7\xb4/G/g;
+$str =~ s/\xc7\xb5/g/g;
+$str =~ s/\xc7\xb8/N/g;
+$str =~ s/\xc7\xb9/n/g;
+$str =~ s/\xc7\xba/A/g;
+$str =~ s/\xc7\xbb/a/g;
+$str =~ s/\xc7\xbe/O/g;
+$str =~ s/\xc7\xbf/o/g;
+$str =~ s/\xe1\xb8\x80/A/g;
+$str =~ s/\xe1\xb8\x81/a/g;
+$str =~ s/\xe1\xb8\x82/B/g;
+$str =~ s/\xe1\xb8\x83/b/g;
+$str =~ s/\xe1\xb8\x84/B/g;
+$str =~ s/\xe1\xb8\x85/b/g;
+$str =~ s/\xe1\xb8\x86/B/g;
+$str =~ s/\xe1\xb8\x87/b/g;
+$str =~ s/\xe1\xb8\x88/C/g;
+$str =~ s/\xe1\xb8\x89/c/g;
+$str =~ s/\xe1\xb8\x8a/D/g;
+$str =~ s/\xe1\xb8\x8b/d/g;
+$str =~ s/\xe1\xb8\x8c/D/g;
+$str =~ s/\xe1\xb8\x8d/d/g;
+$str =~ s/\xe1\xb8\x8e/D/g;
+$str =~ s/\xe1\xb8\x8f/d/g;
+$str =~ s/\xe1\xb8\x90/D/g;
+$str =~ s/\xe1\xb8\x91/d/g;
+$str =~ s/\xe1\xb8\x92/D/g;
+$str =~ s/\xe1\xb8\x93/d/g;
+$str =~ s/\xe1\xb8\x94/E/g;
+$str =~ s/\xe1\xb8\x95/e/g;
+$str =~ s/\xe1\xb8\x96/E/g;
+$str =~ s/\xe1\xb8\x97/e/g;
+$str =~ s/\xe1\xb8\x98/E/g;
+$str =~ s/\xe1\xb8\x99/e/g;
+$str =~ s/\xe1\xb8\x9a/E/g;
+$str =~ s/\xe1\xb8\x9b/e/g;
+$str =~ s/\xe1\xb8\x9c/E/g;
+$str =~ s/\xe1\xb8\x9d/e/g;
+$str =~ s/\xe1\xb8\x9e/F/g;
+$str =~ s/\xe1\xb8\x9f/f/g;
+$str =~ s/\xe1\xb8\xa0/G/g;
+$str =~ s/\xe1\xb8\xa1/g/g;
+$str =~ s/\xe1\xb8\xa2/H/g;
+$str =~ s/\xe1\xb8\xa3/h/g;
+$str =~ s/\xe1\xb8\xa4/H/g;
+$str =~ s/\xe1\xb8\xa5/h/g;
+$str =~ s/\xe1\xb8\xa6/H/g;
+$str =~ s/\xe1\xb8\xa7/h/g;
+$str =~ s/\xe1\xb8\xa8/H/g;
+$str =~ s/\xe1\xb8\xa9/h/g;
+$str =~ s/\xe1\xb8\xaa/H/g;
+$str =~ s/\xe1\xb8\xab/h/g;
+$str =~ s/\xe1\xb8\xac/I/g;
+$str =~ s/\xe1\xb8\xad/i/g;
+$str =~ s/\xe1\xb8\xae/I/g;
+$str =~ s/\xe1\xb8\xaf/i/g;
+$str =~ s/\xe1\xb8\xb0/K/g;
+$str =~ s/\xe1\xb8\xb1/k/g;
+$str =~ s/\xe1\xb8\xb2/K/g;
+$str =~ s/\xe1\xb8\xb3/k/g;
+$str =~ s/\xe1\xb8\xb4/K/g;
+$str =~ s/\xe1\xb8\xb5/k/g;
+$str =~ s/\xe1\xb8\xb6/L/g;
+$str =~ s/\xe1\xb8\xb7/l/g;
+$str =~ s/\xe1\xb8\xb8/L/g;
+$str =~ s/\xe1\xb8\xb9/l/g;
+$str =~ s/\xe1\xb8\xba/L/g;
+$str =~ s/\xe1\xb8\xbb/l/g;
+$str =~ s/\xe1\xb8\xbc/L/g;
+$str =~ s/\xe1\xb8\xbd/l/g;
+$str =~ s/\xe1\xb8\xbe/M/g;
+$str =~ s/\xe1\xb8\xbf/m/g;
+$str =~ s/\xe1\xb9\x80/M/g;
+$str =~ s/\xe1\xb9\x81/m/g;
+$str =~ s/\xe1\xb9\x82/M/g;
+$str =~ s/\xe1\xb9\x83/m/g;
+$str =~ s/\xe1\xb9\x84/N/g;
+$str =~ s/\xe1\xb9\x85/n/g;
+$str =~ s/\xe1\xb9\x86/N/g;
+$str =~ s/\xe1\xb9\x87/n/g;
+$str =~ s/\xe1\xb9\x88/N/g;
+$str =~ s/\xe1\xb9\x89/n/g;
+$str =~ s/\xe1\xb9\x8a/N/g;
+$str =~ s/\xe1\xb9\x8b/n/g;
+$str =~ s/\xe1\xb9\x8c/O/g;
+$str =~ s/\xe1\xb9\x8d/o/g;
+$str =~ s/\xe1\xb9\x8e/O/g;
+$str =~ s/\xe1\xb9\x8f/o/g;
+$str =~ s/\xe1\xb9\x90/O/g;
+$str =~ s/\xe1\xb9\x91/o/g;
+$str =~ s/\xe1\xb9\x92/O/g;
+$str =~ s/\xe1\xb9\x93/o/g;
+$str =~ s/\xe1\xb9\x94/P/g;
+$str =~ s/\xe1\xb9\x95/p/g;
+$str =~ s/\xe1\xb9\x96/P/g;
+$str =~ s/\xe1\xb9\x97/p/g;
+$str =~ s/\xe1\xb9\x98/R/g;
+$str =~ s/\xe1\xb9\x99/r/g;
+$str =~ s/\xe1\xb9\x9a/R/g;
+$str =~ s/\xe1\xb9\x9b/r/g;
+$str =~ s/\xe1\xb9\x9c/R/g;
+$str =~ s/\xe1\xb9\x9d/r/g;
+$str =~ s/\xe1\xb9\x9e/R/g;
+$str =~ s/\xe1\xb9\x9f/r/g;
+$str =~ s/\xe1\xb9\xa0/S/g;
+$str =~ s/\xe1\xb9\xa1/s/g;
+$str =~ s/\xe1\xb9\xa2/S/g;
+$str =~ s/\xe1\xb9\xa3/s/g;
+$str =~ s/\xe1\xb9\xa4/S/g;
+$str =~ s/\xe1\xb9\xa5/s/g;
+$str =~ s/\xe1\xb9\xa6/S/g;
+$str =~ s/\xe1\xb9\xa7/s/g;
+$str =~ s/\xe1\xb9\xa8/S/g;
+$str =~ s/\xe1\xb9\xa9/s/g;
+$str =~ s/\xe1\xb9\xaa/T/g;
+$str =~ s/\xe1\xb9\xab/t/g;
+$str =~ s/\xe1\xb9\xac/T/g;
+$str =~ s/\xe1\xb9\xad/t/g;
+$str =~ s/\xe1\xb9\xae/T/g;
+$str =~ s/\xe1\xb9\xaf/t/g;
+$str =~ s/\xe1\xb9\xb0/T/g;
+$str =~ s/\xe1\xb9\xb1/t/g;
+$str =~ s/\xe1\xb9\xb2/U/g;
+$str =~ s/\xe1\xb9\xb3/u/g;
+$str =~ s/\xe1\xb9\xb4/U/g;
+$str =~ s/\xe1\xb9\xb5/u/g;
+$str =~ s/\xe1\xb9\xb6/U/g;
+$str =~ s/\xe1\xb9\xb7/u/g;
+$str =~ s/\xe1\xb9\xb8/U/g;
+$str =~ s/\xe1\xb9\xb9/u/g;
+$str =~ s/\xe1\xb9\xba/U/g;
+$str =~ s/\xe1\xb9\xbb/u/g;
+$str =~ s/\xe1\xb9\xbc/V/g;
+$str =~ s/\xe1\xb9\xbd/v/g;
+$str =~ s/\xe1\xb9\xbe/V/g;
+$str =~ s/\xe1\xb9\xbf/v/g;
+$str =~ s/\xe1\xba\x80/W/g;
+$str =~ s/\xe1\xba\x81/w/g;
+$str =~ s/\xe1\xba\x82/W/g;
+$str =~ s/\xe1\xba\x83/w/g;
+$str =~ s/\xe1\xba\x84/W/g;
+$str =~ s/\xe1\xba\x85/w/g;
+$str =~ s/\xe1\xba\x86/W/g;
+$str =~ s/\xe1\xba\x87/w/g;
+$str =~ s/\xe1\xba\x88/W/g;
+$str =~ s/\xe1\xba\x89/w/g;
+$str =~ s/\xe1\xba\x8a/X/g;
+$str =~ s/\xe1\xba\x8b/x/g;
+$str =~ s/\xe1\xba\x8c/X/g;
+$str =~ s/\xe1\xba\x8d/x/g;
+$str =~ s/\xe1\xba\x8e/Y/g;
+$str =~ s/\xe1\xba\x8f/y/g;
+$str =~ s/\xe1\xba\x90/Z/g;
+$str =~ s/\xe1\xba\x91/z/g;
+$str =~ s/\xe1\xba\x92/Z/g;
+$str =~ s/\xe1\xba\x93/z/g;
+$str =~ s/\xe1\xba\x94/Z/g;
+$str =~ s/\xe1\xba\x95/z/g;
+$str =~ s/\xe1\xba\x96/h/g;
+$str =~ s/\xe1\xba\x97/t/g;
+$str =~ s/\xe1\xba\x98/w/g;
+$str =~ s/\xe1\xba\x99/y/g;
+$str =~ s/\xe1\xba\x9a/a/g;
+$str =~ s/\xe1\xba\xa0/A/g;
+$str =~ s/\xe1\xba\xa1/a/g;
+$str =~ s/\xe1\xba\xa2/A/g;
+$str =~ s/\xe1\xba\xa3/a/g;
+$str =~ s/\xe1\xba\xa4/A/g;
+$str =~ s/\xe1\xba\xa5/a/g;
+$str =~ s/\xe1\xba\xa6/A/g;
+$str =~ s/\xe1\xba\xa7/a/g;
+$str =~ s/\xe1\xba\xa8/A/g;
+$str =~ s/\xe1\xba\xa9/a/g;
+$str =~ s/\xe1\xba\xaa/A/g;
+$str =~ s/\xe1\xba\xab/a/g;
+$str =~ s/\xe1\xba\xac/A/g;
+$str =~ s/\xe1\xba\xad/a/g;
+$str =~ s/\xe1\xba\xae/A/g;
+$str =~ s/\xe1\xba\xaf/a/g;
+$str =~ s/\xe1\xba\xb0/A/g;
+$str =~ s/\xe1\xba\xb1/a/g;
+$str =~ s/\xe1\xba\xb2/A/g;
+$str =~ s/\xe1\xba\xb3/a/g;
+$str =~ s/\xe1\xba\xb4/A/g;
+$str =~ s/\xe1\xba\xb5/a/g;
+$str =~ s/\xe1\xba\xb6/A/g;
+$str =~ s/\xe1\xba\xb7/a/g;
+$str =~ s/\xe1\xba\xb8/E/g;
+$str =~ s/\xe1\xba\xb9/e/g;
+$str =~ s/\xe1\xba\xba/E/g;
+$str =~ s/\xe1\xba\xbb/e/g;
+$str =~ s/\xe1\xba\xbc/E/g;
+$str =~ s/\xe1\xba\xbd/e/g;
+$str =~ s/\xe1\xba\xbe/E/g;
+$str =~ s/\xe1\xba\xbf/e/g;
+$str =~ s/\xe1\xbb\x80/E/g;
+$str =~ s/\xe1\xbb\x81/e/g;
+$str =~ s/\xe1\xbb\x82/E/g;
+$str =~ s/\xe1\xbb\x83/e/g;
+$str =~ s/\xe1\xbb\x84/E/g;
+$str =~ s/\xe1\xbb\x85/e/g;
+$str =~ s/\xe1\xbb\x86/E/g;
+$str =~ s/\xe1\xbb\x87/e/g;
+$str =~ s/\xe1\xbb\x88/I/g;
+$str =~ s/\xe1\xbb\x89/i/g;
+$str =~ s/\xe1\xbb\x8a/I/g;
+$str =~ s/\xe1\xbb\x8b/i/g;
+$str =~ s/\xe1\xbb\x8c/O/g;
+$str =~ s/\xe1\xbb\x8d/o/g;
+$str =~ s/\xe1\xbb\x8e/O/g;
+$str =~ s/\xe1\xbb\x8f/o/g;
+$str =~ s/\xe1\xbb\x90/O/g;
+$str =~ s/\xe1\xbb\x91/o/g;
+$str =~ s/\xe1\xbb\x92/O/g;
+$str =~ s/\xe1\xbb\x93/o/g;
+$str =~ s/\xe1\xbb\x94/O/g;
+$str =~ s/\xe1\xbb\x95/o/g;
+$str =~ s/\xe1\xbb\x96/O/g;
+$str =~ s/\xe1\xbb\x97/o/g;
+$str =~ s/\xe1\xbb\x98/O/g;
+$str =~ s/\xe1\xbb\x99/o/g;
+$str =~ s/\xe1\xbb\x9a/O/g;
+$str =~ s/\xe1\xbb\x9b/o/g;
+$str =~ s/\xe1\xbb\x9c/O/g;
+$str =~ s/\xe1\xbb\x9d/o/g;
+$str =~ s/\xe1\xbb\x9e/O/g;
+$str =~ s/\xe1\xbb\x9f/o/g;
+$str =~ s/\xe1\xbb\xa0/O/g;
+$str =~ s/\xe1\xbb\xa1/o/g;
+$str =~ s/\xe1\xbb\xa2/O/g;
+$str =~ s/\xe1\xbb\xa3/o/g;
+$str =~ s/\xe1\xbb\xa4/U/g;
+$str =~ s/\xe1\xbb\xa5/u/g;
+$str =~ s/\xe1\xbb\xa6/U/g;
+$str =~ s/\xe1\xbb\xa7/u/g;
+$str =~ s/\xe1\xbb\xa8/U/g;
+$str =~ s/\xe1\xbb\xa9/u/g;
+$str =~ s/\xe1\xbb\xaa/U/g;
+$str =~ s/\xe1\xbb\xab/u/g;
+$str =~ s/\xe1\xbb\xac/U/g;
+$str =~ s/\xe1\xbb\xad/u/g;
+$str =~ s/\xe1\xbb\xae/U/g;
+$str =~ s/\xe1\xbb\xaf/u/g;
+$str =~ s/\xe1\xbb\xb0/U/g;
+$str =~ s/\xe1\xbb\xb1/u/g;
+$str =~ s/\xe1\xbb\xb2/Y/g;
+$str =~ s/\xe1\xbb\xb3/y/g;
+$str =~ s/\xe1\xbb\xb4/Y/g;
+$str =~ s/\xe1\xbb\xb5/y/g;
+$str =~ s/\xe1\xbb\xb6/Y/g;
+$str =~ s/\xe1\xbb\xb7/y/g;
+$str =~ s/\xe1\xbb\xb8/Y/g;
+$str =~ s/\xe1\xbb\xb9/y/g;
+$str =~ s/\xe1\xbb\xbe/Y/g;
+$str =~ s/\xe1\xbb\xbf/y/g;
+
+
+$str =~ s/\xc3\x9f/s/g;
+# $str =~ s/\xe2\x94\x80/-/g;
+
+ if ( $ori eq $str && ! &containsutf8nonchar($str) && ord($str) != 204 ) {
+
+ $logger->error("utf8_to_ascii() could not transform |$str| (". ord($str).")");
+ }
+ return($str);
+}
+
+sub containsutf8nonchar {
+ my ($str) = @_;
+ if ( $str =~ /\xe2\x94\x80/
+ | $str =~ /\xc2\xab/
+ | $str =~ /\xc2\xbb/
+ | $str =~ /\xca\xbf/
+ | $str =~ /\xcc\x84/
+ ) {
+
+ return 1;
+ }
+ else {
+ return 0;
+ }
+
+}
+
+### just for testing purposes:
+
+sub xreverse {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ return ( scalar reverse ($string ) );
+
+}
+
+sub xsep2revclone {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ($string) {
+ return ( "$string&&&".$self->xreverse($string) );
+ } else {
+ return("");
+ }
+}
+
+
+sub xaddblanks {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ($string) {
+ return ( join (' ', split(/ */, $string) ) );
+ }
+}
+
+
+sub xcreatemd5 {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ if ($string) {
+ use Digest::MD5 qw(md5 md5_hex md5_base64);
+ $string = '{MD5}'.md5_base64($string).'==';
+ return ( $string) ;
+ }
+ else {
+ return('');
+ }
+
+}
+
+sub xdummy {
+ my $self = shift;
+ my ( $string ) = @_;
+ if ( $string) {
+ return ('dummy');
+ }
+ else {
+ return('');
+ }
+
+}
+
+
+
+sub xcodes2utf {
+ my $self = shift;
+ my ( $string ) = @_;
+
+# if ( $string =~ /Bhakti/ ) {
+# print "Hare Krishna\n";
+# }
+
+
+ if ( $self->{data}{'isrealutf8'} ) {
+ $logger->debug("this is realutf8");
+ return ( $self->xcodes2utf8($string) );
+ }
+
+## the following should be renamed to xcodes2htmlentities
+ $logger->debug("this is xcodes2utf");
+
+ if ( ! $self->{data}{'codetabisloaded'} ) {
+ $logger->debug("Loading Code table: isloaded: $self->{data}{'codetabisloaded'}");
+ $self->loadcodetable();
+ $self->{data}{'codetabisloaded'} = 1;
+ }
+
+ if ( $string) {
+ no warnings;
+ if ( $string =~ /[\#\^%ÜÖÄüöäß]/ ) {
+ no warnings;
+ foreach my $code ( reverse sort keys %{$self->{data}{codes}} ) {
+# print "Code: $code\n";
+ my $safecode = $self->makeRegexpSafe($code);
+ $string =~ s/$safecode/$self->{data}{codes}{$code}/g;
+ }
+ use warnings;
+# print "converted $string\n";
+ }
+ use warnings;
+
+ return ($string);
+ }
+ else {
+ return('');
+ }
+}
+
+
+sub xutf82codes {
+ my $self = shift;
+ my ( $string ) = @_;
+
+### didn't work: DeviP=Dev^%:A^#.<pur^%:A^%/a^^^1a
+
+# if ( ! $self->{data}{'utfcodetabisloaded'} ) {
+# $logger->debug("Loading UTF Code table: isloaded: $self->{data}{'utfcodetabisloaded'}");
+# $self->loadutf8codetable();
+# $self->{data}{'utfcodetabisloaded'} = 1;
+# }
+
+ if ( $string) {
+# foreach my $code ( reverse sort keys %{$self->{data}{utf8codes}} ) {
+# print "Code: $code\n";
+#
+# my $safecode = $self->makeRegexpSafe($code);
+# $string =~ s/$safecode/$self->{data}{utf8codes}{$code}/g;
+# }
+
+ $string =~ s/\xc4\x81/%-a/g; # amacron
+ $string =~ s/\xc4\xab/%-i/g; # imacron
+ $string =~ s/\xc5\xab/%-u/g; # umacron
+ $string =~ s/\xc5\x9b/%\/s/g; # s with acute
+ $string =~ s/\xc5\x9a/%\/S/g; # S with acute
+ $string =~ s/\xe1\xb9\xa3/%..s/g; # n with dor below
+ $string =~ s/\xe1\xb9\x87/%..n/g; # n with dor below
+ $string =~ s/\xe1\xb9\x9b/%..r/g; # r with dor below
+ $string =~ s/\xe1\xb9\x9a/%..R/g; # R with dor below
+
+ return $string;
+ }
+ else {
+ return '';
+ }
+}
+
+sub xcodes2utf8 {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ $logger->debug("this is xcodes2utf8");
+
+ if ( ! $self->{data}{'utfcodetabisloaded'} ) {
+ $logger->debug("Loading UTF Code table: isloaded: $self->{data}{'utfcodetabisloaded'}");
+ $self->loadutf8codetable();
+ $self->{data}{'utfcodetabisloaded'} = 1;
+ }
+
+ if ( $string) {
+# if ( $string =~ /[\#\^%ÜÖÄüöäß]/ ) {
+ $string =~ s/\.\^-/\. --/g;
+ $string =~ s/\^-/--/g;
+
+
+
+ if ( $string =~ /[\#\^%]/ ) {
+ $logger->debug("found codes in |$string|");
+ foreach my $code ( reverse sort keys %{$self->{data}{codes}} ) {
+# print "Code: $code\n";
+
+ my $safecode = $self->makeRegexpSafe($code);
+ $string =~ s/$safecode/$self->{data}{codes}{$code}/g;
+ }
+ $logger->debug("converted string to: |$string|\n");
+ }
+
+ return ($string);
+ }
+ else {
+ return('');
+ }
+}
+
+sub loadcodetable {
+ my $self = shift;
+
+ my $fh;
+ my $filename = $self->{data}{codesfile};
+
+ if ( ! -e $filename ) {
+ print "file $filename not found\n";
+ exit();
+ }
+ open ($fh, "<$filename");
+
+ no warnings;
+
+ while ( <$fh>) {
+ if ( /[äöüÄÖÜß\#%\^]/) {
+ if ( /([0-9A-F]{4,4})([=><\^:])(.+)/ ) {
+ my $htmlentity = "&#x$1;";
+ $self->{data}{codes}{$3}=$htmlentity;
+ $self->{data}{revcodes}{$1}=$3;
+ }
+ }
+ }
+ use warnings;
+ close($fh);
+ return;
+}
+
+
+sub loadutf8codetable {
+ my $self = shift;
+
+ my $fh;
+ my $filename = $self->{data}{codesfile};
+
+ if ( ! -e $filename ) {
+ print "file $filename not found\n";
+ exit();
+ }
+ open ($fh, "<$filename");
+
+ while ( <$fh>) {
+# if ( /[äöüÄÖÜß\#%\^]/) {
+ if ( /[\#%\^]/) {
+ if ( /([0-9A-F]{4,4})([=><\^:])(.+?)([=])(.*?)/ ) {
+ my $utf8char = chr (hex($1));
+ $self->{data}{codes}{$3}=$utf8char;
+ $self->{data}{revcodes}{$1}=$3;
+# $self->{data}{utf8codes}{$utf8char}=$3;
+ if ($5) {
+ push @{$self->{data}{altcodes}{$5}}, $utf8char;
+ }
+ }
+ elsif ( /([0-9A-F]{4,4})([=><\^:])(.+)/ ) {
+ my $utf8char = chr (hex($1));
+ $self->{data}{codes}{$3}=$utf8char;
+ $self->{data}{revcodes}{$1}=$3;
+# $self->{data}{utf8codes}{$utf8char}=$3;
+ }
+ }
+ }
+ close($fh);
+ return;
+}
+
+
+sub htmlutf2codes {
+ my $self = shift;
+ my ( $string ) = @_;
+
+# $logger->debug("htmlutf2codes(): starting");
+ if ( ! $string ) {
+ return ('');
+ }
+
+ if ( ! $self->{data}{'codetabisloaded'} ) {
+ $logger->debug("Loading Code table: isloaded: $self->{data}{'codetabisloaded'}");
+ $self->loadcodetable();
+ $self->{data}{'codetabisloaded'} = 1;
+ }
+
+# $string =~ s/&\#x(00)([0-9A-F]{2,2});/chr(hex($2))/ge;
+
+ $string =~ s/&\#x([0-9A-F]{4,4});/$self->{data}{revcodes}{$1}/ge;
+
+
+# $logger->debug("htmlutf2codes(): returning $string");
+
+ return $string;
+
+}
+
+
+
+sub utf82htmlutf {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ $logger->debug("utf82htmlutf(): starting");
+ if ( ! $string ) {
+ return ('');
+ }
+
+ if ( $string =~ s/([\xc2-\xe2])(.)/"&\#".uc(sprintf("%x",ord($1))).uc(sprintf("%x",ord($2))).";"/ge ) {
+ my $x1 = ord($1);
+ my $s1 = sprintf("%x",$x1);
+ my $x2 = ord($1);
+ my $s2 = sprintf("%x",$x1);
+
+ $logger->debug("x1: $x1, s1: $s1, String: $string");
+ }
+ else {
+ $string = '';
+ }
+
+ $logger->debug("utf82htmlutf(): returning $string");
+
+ return $string;
+
+}
+
+
+sub found_in_dictionary {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ my $equivalent = '';
+
+ $logger->debug("this is found_in_dictionary");
+
+ if ( $string) {
+
+ if ( $self->{data}{'dictionaryfile'} &&
+ (! $self->{data}{'dictionaryfileisloaded'})
+ ) {
+ $logger->info("Loading dictionary: $self->{data}{'dictionaryfileisloaded'}");
+ $self->loaddictionary();
+ $self->{data}{'dictionaryfileisloaded'} = 1;
+ }
+
+
+ $equivalent = $self->{data}{dictionary}{$string};
+ if ( ! $equivalent ) {
+ $equivalent = $self->{data}{dictionary}{lc($string)};
+ }
+ if ( ! $equivalent ) {
+ $equivalent = $self->lookForSubstringsInDict(lc($string));
+ }
+ if ( $equivalent ) {
+
+ $logger->debug("found |$equivalent| from |$string|");
+ }
+ return ($equivalent);
+ }
+ else {
+ return('');
+ }
+}
+
+
+
+sub lookForSubstringsInDict {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ my $equivalent = '';
+
+ $logger->debug("this is found_in_dictionary");
+
+ foreach my $key ( keys %{$self->{data}{dictionary}} ) {
+ if ( $key =~ /^(.*)($string)(.*)$/ ) {
+ my $val = $self->{data}{dictionary}{$key};
+
+ $equivalent = substr($val,length($1),length($string));
+ $logger->debug("Found substring of $string in $val: equiv: $equivalent");
+ last;
+
+ }
+
+ }
+ return ( $equivalent );
+}
+
+sub loaddictionary {
+ my $self = shift;
+
+ my $fh;
+ my $filename = $self->{data}{dictionaryfile};
+
+ if ( ! -e $filename ) {
+ print "file $filename not found\n";
+ exit();
+ }
+# open ($fh, "<$filename");
+ open ($fh, "<:utf8", $filename);
+
+ while ( <$fh>) {
+ if ( /^(.+?)=(.+)/ ) {
+# $logger->debug("***************** $1 = $2");
+# eval ( decode_utf8($1));
+# $self->{data}{dictionary}{$2}=$1;
+ $self->{data}{dictionary}{lc($1)}=$2;
+ }
+ }
+ close($fh);
+ return;
+}
+
+
+sub xcreatevaluefromLDAP {
+ my $self = shift;
+ my ( $string, $rh_paras ) = @_;
+
+ if ( ! $string ) {
+ return ('');
+ }
+
+ my $searchattr;
+
+ $string =~ s/\+/;/g;
+
+ my ($searchval, $attrname, $is_iso_to_utf, $function, $is_multi) = split /;/, $string, 5 ;
+
+# print "xcreatevaluefromLDAP called with paras:\n 1.) $searchval\n";
+# print " 2.) $attrname\n 3.) $otherparams\n 4.) [$rh_paras->{parameter2}]\n";
+
+ $attrname =~ s/^'(.*)'$/$1/;
+
+ $logger->debug("xcreatevaluefromLDAP called with paras:");
+ $logger->debug(" 1.) searchval: $searchval");
+ $logger->debug(" 2.) attrname: $attrname");
+ $logger->debug(" 3.) is_iso_to_utf: $is_iso_to_utf") if $is_iso_to_utf;
+ $logger->debug(" 4.) function: $function") if $function;
+ $logger->debug(" 5.) is_multi: $is_multi") if $is_multi;
+ $logger->debug(" 6.) parameter2: [$rh_paras->{parameter2}]");
+
+
+ if ( $rh_paras->{parameter2} =~ /^(ldap):/ ) {
+ my $prot = $1;
+
+ if ( ! $self->{valueldapconnection} ) {
+ $self->{valueldapserverdef} =
+ $libldap->defineServerFromURI($rh_paras->{parameter2},
+ 'accountdatasource');
+ $logger->debug("setting up connection to accountdata source");
+ $self->{valueldapconnection} =
+ $libldap->connectServer($self->{valueldapserverdef});
+ }
+
+ if ( $prot eq 'ldap' ) {
+ $searchattr = $data->getTokenValue($rh_paras->{parameter2},
+ "searchattr=", ";");
+# $mappingattr = $data->getTokenValue($rh_paras->{parameter2},
+# "mapping=", ";");
+
+
+ } else {
+ $logger->error("Wrong protocol in uri! Giving up conversion");
+ return $string;
+ }
+ }
+ my $searchtype = 'exact';
+
+ my $newvalue = $libldap->searchValueFromLDAP($attrname, $searchval,
+ $searchattr,
+ $rh_paras->{parameter2},
+ $searchtype,
+ 'acountdatasource',
+ $self->{valueldapconnection},
+ $self->{valueldapserverdef},
+ $is_multi
+ );
+
+# print "newvalue befor: $newvalue\n";
+ if ( $newvalue) {
+ if ( $is_iso_to_utf ) {
+ $newvalue = $self->convert('iso-to-utf', $newvalue);
+ }
+ if ( $function ) {
+ $newvalue = $self->convert($function, $newvalue);
+ }
+
+ }
+# print "newvalue after: $newvalue\n";
+# exit();
+ return($newvalue);
+}
+
+sub connectLdapServer {
+
+ my $self = shift;
+
+ my ($prot, $host, $port, $version, $binddn, $pw, $basedn, $scope, $timelimit) = @_;
+
+ my $ldap = DAASIlib::LDAP->new();
+
+ my $def = $ldap->defineServer($prot, $host, $port, $version, $binddn, $pw, $basedn, $scope, undef, undef, undef, $timelimit);
+
+ $self->{ 'ldapconnection' } = $ldap->connectServer( $def );
+
+ return ($self->{ 'ldapconnection' });
+
+}
+
+
+
+
+1;
+
+# some old stuff
+# my $first = substr($1,0,2);
+# my $second = substr($1,2,2);
+# my $utf = chr(hex($first)).chr(hex($second));
+# my $utf16 = chr(hex($1));
+# my $utf8 = decode("UTF-32", $utf16);
+# my $utf8 = $self->convert("UTF-16-to-UTF-8", $utf16);
+# if ($utf) {
+# $self->{data}{codes}{$3}=$utf;
+# print "|$3| |$2| |$utf8| ($first $second)\n";
+# }
+# else {
+# print "could not convert $3 ($1)\n";
+# }
+
+# my $utfchar = chr($1);
+# my $utfchar = chr("\x{$1}");
+# my $coderef = "0x$1";
+# $coderef = $coderef+0;
+# my $utfchar = pack("U0U*",$coderef);
+# print "UTF of $1: $utfchar\n";
+# last;
+
+# $self->{data}{codes}{$3}="\x{$1}";
+# $self->{data}{codes}{$3}=chr("\x{$1}");
+# $self->{data}{codes}{$3}=chr($1);
+# $self->{data}{codes}{$3}=chr("0x$1");
+# $self->{data}{codes}{$3}=hex($1);
+# $self->{data}{codes}{$3}=chr(hex($1));
+# $self->{data}{codes}{$3}=$1;
+
+# use Data::Dumper;
+# print Dumper($self->{data}{codes});
+# foreach my $code ( keys %{$self->{data}{codes}} ) {
+# print "code: $code\n";
+# }
+
+
+
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+DAASIlib::Convert - Perl extension for blah blah blah
+
+=head1 SYNOPSIS
+
+ use DAASIlib::Convert;
+ blah blah blah
+
+=head1 DESCRIPTION
+
+Stub documentation for DAASIlib::Convert, created by h2xs. It looks like the
+author of the extension was negligent enough to leave the stub
+unedited.
+
+Blah blah blah.
+
+=head2 EXPORT
+
+None by default.
+
+
+
+=head1 SEE ALSO
+
+Mention other useful documentation such as the documentation of
+related modules or operating system documentation (such as man pages
+in UNIX), or any relevant external documentation such as RFCs or
+standards.
+
+If you have a mailing list set up for your module, mention it here.
+
+If you have a web site set up for your module, mention it here.
+
+=head1 AUTHOR
+
+Peter Gietz, E<lt>zrngi01@suse.deE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2005 by Peter Gietz
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/Data.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/Data.pm
new file mode 100644
index 0000000000000000000000000000000000000000..9f09d208005d71ebd06990181609787702d53a65
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/Data.pm
@@ -0,0 +1,506 @@
+#!/usr/bin/perl -w
+
+
+package DAASIlib::Data;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+
+use DBI;
+use Log::Log4perl qw(:levels);
+use File::Basename;
+#use Sys::Hostname;
+use Socket;
+#use Net::Nslookup;
+
+my $logger = Log::Log4perl->get_logger('');
+
+our $VERSION = "0.10";
+
+our $PROGNAME;
+our $SECRETFILE;
+
+sub new {
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ };
+
+ bless($self , $class );
+
+ return $self;
+
+}
+
+
+sub init {
+ my $self = shift;
+ my ($progname, $pwfile) = @_;
+
+# print "Data.pm: Setting progname $progname\n";
+ $PROGNAME = $progname;
+ $SECRETFILE = $pwfile
+
+}
+
+sub progname {
+ return $PROGNAME;
+}
+
+sub test {
+ print "########### TEST\n";
+}
+
+sub getProgramFiles {
+ my $self = shift;
+ my ( $call, $addtoetc ) = @_;
+
+ my ($progname, $progpath, $progsuffix, $etcdir, $sysconfig);
+
+ ($progname, $progpath, $progsuffix) = fileparse($call, ".pl");
+
+ if ( $progpath =~ /^\.[^.]/ ) {
+ my $longpath = `pwd`;
+ chomp($longpath);
+ $progpath =~ s/^./$longpath/;
+ }
+ if ( $addtoetc ) {
+ $etcdir = "${progpath}${addtoetc}etc/";
+ if ( ! -e "${etcdir}${progname}.sys" ) {
+ $etcdir = "${progpath}${addtoetc}${addtoetc}etc/";
+ if ( ! -e "${etcdir}${progname}.sys" ) {
+ print "sysfile not found\n";
+ }
+ }
+
+ }
+ else {
+ $etcdir = "${progpath}etc/";
+ }
+ $sysconfig = "${etcdir}${progname}.sys";
+
+ return ($progname, $progpath, $etcdir, $sysconfig);
+
+}
+
+
+
+sub getTokenValue {
+ my $self = shift;
+ my ( $string, $token, $endvaluetoken ) = @_;
+
+ if ( $string !~ /$endvaluetoken$/ ) {
+ $string.=$endvaluetoken;
+ }
+
+ my $value="";
+
+ if ( $string =~ /$token(.*?)$endvaluetoken/ ) {
+ $value = $1;
+ } else {
+ $logger->warn("Token $token missing in dbi:-parameters");
+ }
+
+ return($value);
+}
+
+sub getTokenValueFromFile {
+ my $self = shift;
+ my ( $token, $filename ) = @_;
+
+ my $value;
+ my $is_open=0;
+
+ if ( ! -e $filename ) {
+ $logger->error("File $filename does not exist!");
+ } else {
+ $is_open = open ( FH, "<$filename") ||
+ $logger->error("Couldn't open file $filename!");
+ }
+
+# print "is_open: [$is_open]\n";
+ if ( $is_open ) {
+ while ( <FH> ) {
+ if ( $_ =~ /$token\s*(.*)/ ) {
+ $value = $1;
+ last;
+ }
+ }
+ close (FH);
+ }
+
+ if (! $value ) {
+ $logger->error("found empty value of token $token in file $filename");
+ } else {
+ $logger->debug("found value of token $token in file $filename");
+ }
+
+ return($value);
+}
+
+
+
+
+sub getSecret {
+ my $self = shift;
+ my ( $param ) = @_;
+
+ $logger->debug("getSecret $param from $SECRETFILE");
+# my $secretfile = "$PROGNAME.secret";
+ my $secret;
+
+ if ( ! -e $SECRETFILE ) {
+ $logger->logdie("File $SECRETFILE does not exist!");
+ }
+ open ( FH, "< $SECRETFILE") ||
+ $logger->logdie("Couldn't open secret file $SECRETFILE!");
+
+ while ( <FH> ) {
+ if ( $_ =~ /$param\s+(.*)/ ) {
+ $secret = $1;
+ last;
+ }
+ }
+
+ close (FH);
+
+ if (! $secret ) {
+ $logger->error("found empty or no value for $param in secret file $SECRETFILE");
+ print "may be token $param is missing in file $SECRETFILE\n";
+ } else {
+ $logger->debug("found pw of $param in secret file $SECRETFILE");
+ }
+
+ return($secret);
+}
+
+sub areTheyDifferent {
+ my $self = shift;
+ my ($ra_newvalues, $ra_oldvalues, $is_casesensitive) = @_;
+
+ my @diff = ();
+ my %count;
+ my $e;
+
+
+ if ( $is_casesensitive) {
+ foreach $e ( @{$ra_newvalues}, @{$ra_oldvalues}) {
+ $count{$e}++;
+ }
+ }
+ else {
+ foreach $e ( @{$ra_newvalues}, @{$ra_oldvalues}) {
+ $count{lc($e)}++;
+ }
+ }
+
+ foreach $e ( keys %count) {
+ if ( $count{$e} != 2 ) {
+ $logger->debug("found difference in value $e which occurs $count{$e} instead of 2");
+ push @diff, $e;
+ }
+ }
+
+ return ($diff[0] );
+
+}
+
+sub arrayToLower {
+ my $self = shift;
+ my ($ra_values) = @_;
+
+ foreach (@{$ra_values}) {
+ $_ = lc($_);
+ }
+
+ return ($ra_values);
+}
+
+sub findNewValues {
+ my $self = shift;
+ my ($ra_newvalues, $ra_oldvalues, $is_caseignore) = @_;
+
+ # only give back those values in newvalues that are not in oldvalues
+ # print "findNewValues got new: [@{$ra_newvalues}], old: [@{$ra_oldvalues}]\n";
+ my %seen;
+
+ if ( $is_caseignore ) {
+ @seen{@{$self->arrayToLower($ra_newvalues)}} = ();
+ delete @seen{@{$self->arrayToLower($ra_oldvalues)}};
+ }
+ else {
+ @seen{@{$ra_newvalues}} = ();
+ delete @seen{@{$ra_oldvalues}};
+ }
+ my @newonly = keys %seen;
+# print "findNewValues returns: [".join ('|', @newonly)."]\n";
+ return (@newonly);
+}
+
+sub findIntersection {
+ my $self = shift;
+ my ($ra_newvalues, $ra_oldvalues, $is_caseignore ) = @_;
+
+ # only give back those array elements that are both in newvalues and in oldvalues
+ my @a;
+ my @b;
+
+ @a = $is_caseignore ? @{$self->arrayToLower($ra_newvalues)}
+ : @{$ra_newvalues} ;
+ @b = $is_caseignore ? @{$self->arrayToLower($ra_oldvalues)}
+ : @{$ra_oldvalues} ;
+
+ @a = $self->makeUnique(@a);
+ @b = $self->makeUnique(@b);
+ my %union=();
+ my %isect = ();
+ my @isect=();
+ my $e;
+
+ foreach $e (@a) { $union{$e} = 1; }
+ foreach $e (@b) {
+ if ( $union{$e} ) { $isect{$e} = 1; }
+ $union{$e} = 1;
+ }
+
+ @isect = keys %isect;
+
+# print "isect: [@isect]\n";
+ return (@isect);
+}
+
+
+
+sub makeUnique {
+ my $self = shift;
+ my ( @nonunique ) = @_;
+
+ my %union=();
+
+ foreach my $e (@nonunique) {
+ $union{$e} = 1;
+ }
+
+ my @unique = keys %union;
+
+ return(@unique);
+}
+
+sub removeElements {
+ my $self = shift;
+ my ( $ra_unclean, $pattern ) = @_;
+ my %union;
+# print "Pattern: /$pattern/\n";
+ if ( $pattern =~ /^\/(.*)\/$/) { $pattern = $1; }
+
+ foreach my $e (@{$ra_unclean}) {
+ if ( $e !~ /$pattern/ ) {
+ $union{$e} = 1;
+ }
+ }
+ return ( keys %union);
+
+}
+
+
+sub getmax {
+ my $self = shift;
+ my @values = @_;
+
+ my $max = shift @values;
+
+ foreach ( @values ) {
+ if ( $_ > $max ) {
+ $max = $_;
+ }
+ }
+ return $max;
+}
+
+
+sub maxLen {
+ my $self = shift;
+ my ($ra_strings, $maxlen) = @_;
+
+# use Data::Dumper;
+# print Dumper($ra_strings);
+# exit();
+ my @array = @{$ra_strings};
+
+ if ( $maxlen) {
+ $maxlen = length(shift(@array));
+ }
+ else { $maxlen = 0; }
+
+ foreach (@array) {
+ $maxlen = length($_) > $maxlen ? length($_) : $maxlen;
+ }
+ return ($maxlen);
+}
+
+
+sub hideMail {
+ my $self = shift;
+ my ($mail, $img) = @_;
+
+ my @parts = split /\@/, $mail;
+ my $hidden_mail = $parts[0].'<img src="' .
+ $img .
+ '" border="0" style="position:relative;top:3px">'.$parts[1];
+
+ return ($hidden_mail);
+}
+
+
+sub fileTimeStamp {
+
+ my ( $sek, $min, $hour, $day, $mon, $year ) = localtime();
+ my $filetimestamp = sprintf("%4d%02d%02d-%02d%02d%02d", $year+1900,
+ $mon+1, $day, $hour, $min, $sek);
+
+ return($filetimestamp);
+}
+
+
+sub containsarrayelement {
+ my $self = shift;
+ my ( $string, $arrptr ) = @_;
+
+ my $contains = 0;
+
+ foreach ( @{$arrptr} ) {
+ if ( $string =~ /$_/ ) {
+ $contains = 1;
+ }
+ }
+
+ return $contains;
+}
+
+
+sub incrementfile {
+ my $self = shift;
+ my ($filename, $len) = @_;
+ # stolen from perl cook book:
+ use Fcntl qw(:DEFAULT :flock);
+
+ sysopen(FH, $filename, O_RDWR|O_CREAT)
+ or die "Kann $filename nicht oeffnen: $!";
+
+ flock(FH, LOCK_EX)
+ or die "kein Schreiblock auf $filename: $!";
+
+ my $number = <FH> || 0;
+
+ seek(FH,0,0)
+ or die "kann $filename nicht neu positionieren: $!";
+
+ truncate (FH,0)
+ or die "kann $filename nicht neu positionieren: $!";
+
+ $number++;
+ if ($len) {
+ $number = sprintf("%0${len}d",$number);
+ }
+
+ print FH $number."\n"
+ or die "kann $filename nicht schreiben: $!";
+
+ close (FH)
+ or die "kann $filename nicht schliessen: $!";
+
+ return $number;
+
+}
+
+
+sub getpid {
+ my $self = shift;
+ my ( $pidfile ) = @_;
+ open FH, "<$pidfile" or print " couldn't open pid file $pidfile\n";
+ $/ = "";
+ my $pid = <FH>;
+ chomp($pid);
+
+ $/="\n";
+ return $pid;
+}
+
+sub gethost {
+ my $self = shift;
+
+# my $host = hostname;
+ my $ip = $self->getip();
+ my $iaddr = inet_aton($ip);
+ my $host = gethostbyaddr($iaddr, AF_INET);
+# my $host = nslookup(host => $ip, server => '192.168.100.16');
+ return $host;
+}
+
+sub getip {
+ my $self = shift;
+ my $ip;
+
+ my $interface;
+ my %IPs;
+
+ foreach ( qx{ (LC_ALL=C /sbin/ifconfig -a 2>&1) } ) {
+ $interface = $1 if /^(\S+?):?\s/;
+ next unless defined $interface;
+ $IPs{$interface}->{STATE}=uc($1) if /\b(up|down)\b/i;
+ $IPs{$interface}->{IP}=$1 if /inet\D+(\d+\.\d+\.\d+\.\d+)/i;
+ }
+
+ if ( $IPs{'eth0'} ) {
+ $ip = $IPs{'eth0'}{IP};
+ }
+ else {
+ foreach ( keys %IPs ) {
+ if ( $_ ne 'lo' ) {
+ $ip = $IPs{$_}{IP};
+ }
+ }
+ }
+
+ if ( ! $ip ) {
+ $ip = $IPs{'lo'}{IP};
+ }
+
+ if ( ! $ip ) {
+ $ip = '127.0.0.1';
+ }
+
+ return $ip;
+}
+
+sub getrandchar {
+ my $self = shift;
+
+ my $char ='';
+ my $x = int(rand(10));
+
+ if ( $x > 4 ) {
+ $char = chr(int(rand(91-33)+33));
+ }
+ else {
+ $char = chr(int(rand(126-97)+97));
+ }
+
+ return $char;
+}
+
+
+##################################
+### here come some File oriented methods may be they should go into
+### a DAASIlib::File.pm
+
+
+
+1;
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/Gettext.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/Gettext.pm
new file mode 100644
index 0000000000000000000000000000000000000000..d7572171dbdadb87151bf506b1d3e72a5e84f42c
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/Gettext.pm
@@ -0,0 +1,143 @@
+#!/usr/bin/perl -w
+
+
+package DAASIlib::Gettext;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+
+use Log::Log4perl qw(:levels);
+
+my $logger = Log::Log4perl->get_logger("main");
+
+our $VERSION = "0.10";
+
+use DAASIlib::Data;
+my $data = new DAASIlib::Data;
+
+
+our %TRANSLATIONS;
+our $DEFAULTLANG = 'en_EN';
+our $LANGUAGE = 'de_DE';
+
+our $ACTIVE = 0;
+
+sub new {
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ };
+
+ bless($self , $class );
+
+ return $self;
+
+}
+
+sub init {
+ my $self = shift;
+ my ( $filename, $lang ) = @_;
+
+ if ( ! $lang) {
+ $lang = $LANGUAGE;
+ }
+
+ $lang = $self->getlangstraight($lang);
+
+
+
+ my $msgid;
+ my $msgstr;
+
+ open FH, "<$filename" or die "cannot open file $filename for read: $!";
+ while ( <FH> ) {
+ chomp;
+
+ if ( /^msgstr "(.+)"/ ) {
+ $msgstr = $1;
+ if ( $msgstr && ! $msgid ) {
+ print "gettext::init: Error msgstr |$msgstr| without msgid "
+ ."in file $filename\n";
+ }
+ else {
+# print "setting for $lang id: |$msgid| to string |$msgstr|\n";
+ $TRANSLATIONS{$lang}{$msgid} = $msgstr;
+ $msgstr = '';
+ $msgid = '';
+ }
+ }
+
+ if ( /^msgid "(.+)"/ ) {
+ $msgid = $1;
+ }
+ }
+ close (FH);
+ $ACTIVE = 1;
+}
+
+
+sub setlanguage {
+ my $self = shift;
+ my ( $lang ) = @_;
+
+ $lang = $self->getlangstraight($lang);
+# print "setting lang to $lang\n";
+ $LANGUAGE = $lang;
+}
+
+sub getlanguage {
+ my $self = shift;
+ return $LANGUAGE;
+}
+
+sub getlangstraight {
+ my $self = shift;
+ my ( $lang ) = @_;
+
+ if ( length( $lang ) == 2 ) {
+ $lang = lc($lang).'_'.uc($lang);
+ }
+
+ return $lang;
+}
+
+sub print {
+ my $self = shift;
+ my ( $lang ) = @_;
+ print "printing |$lang|\n";
+ foreach my $key ( keys %{$TRANSLATIONS{$lang}} ) {
+ print "$key: $TRANSLATIONS{$lang}{$key}\n";
+ }
+ print "printing ended\n";
+
+}
+
+sub text {
+ my $self = shift;
+
+ my ( $string ) = @_;
+
+ if ( ! $ACTIVE || $LANGUAGE eq $DEFAULTLANG ) {
+ return $string;
+ }
+#print "gt->text() lang is $LANGUAGE\n";
+ my %langx = %{$TRANSLATIONS{$LANGUAGE}};
+ if ( $langx{$string} ) {
+ return ( $TRANSLATIONS{$LANGUAGE}->{$string} );
+ }
+ else {
+# print "not found\n";
+ return ($string);
+ }
+
+}
+
+
+1;
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/LDAP.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/LDAP.pm
new file mode 100644
index 0000000000000000000000000000000000000000..4d0a66746b5e441a620f4db7c9ea2e9b947f404c
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/LDAP.pm
@@ -0,0 +1,2247 @@
+#!/usr/bin/perl -w
+
+
+package DAASIlib::LDAP;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+our $VERSION = "0.33";
+
+use Log::Log4perl qw(:levels);
+my $logger = Log::Log4perl->get_logger('');
+use DAASIlib::Data;
+my $data = new DAASIlib::Data;
+
+
+use Net::LDAP qw(LDAP_SUCCESS LDAP_TIMELIMIT_EXCEEDED LDAP_SIZELIMIT_EXCEEDED
+ LDAP_NO_SUCH_OBJECT LDAP_ALREADY_EXISTS );
+use Net::LDAP::LDIF;
+use Net::LDAP::Entry;
+use Net::LDAP::Util;
+use Net::LDAP::Schema;
+#use Net::LDAP::Constant qw();
+use MIME::Base64;
+
+sub new {
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ };
+
+ bless($self , $class );
+
+ return $self;
+
+}
+
+
+sub initReplogFile {
+ my $self = shift;
+ my ($filename, $replogfile, $is_removefile) = @_;
+
+ use File::Flock;
+ use File::Temp qw/ tempfile tempdir /;
+
+ my $fh = new File::Temp(TEMPLATE => 'dbconnector.XXXXX',
+ SUFFIX => '.tmp',
+ UNLINK => 0,
+ );
+ if ( ! $filename ) {
+ $filename = $replogfile;
+ if ( ! $filename) {
+ ### todo früher in CONF abfangen
+ $logger->logdie("Replication logfile specification is missing. You have to either specify it with inputfile (-i) or as part of inputuri (-u)");
+ }
+
+ }
+ open (my $fpin, "<$filename") ||
+ $logger->logdie("Couldn't open input file $filename");
+ lock($filename);
+
+
+ {
+ my $oldFN = select( $fpin);
+ local ( $/, $\ );
+ undef $/; undef $\;
+ select( $oldFN );
+
+ my $data = <$fpin>;
+ print $fh $data;
+ }
+ close ($fpin);
+
+# if ( $filename !~ /.tmp$/ ) {
+ if ( $is_removefile ) {
+ $logger->debug("erasing $filename");
+ if ( !open( $fpin, "> $filename" )) {
+ print STDOUT "couldn't erase replog file <$filename>: $!";
+ }
+ close ($fpin);
+ }
+ $logger->debug("unlocking $filename");
+ unlock($filename);
+
+ return ($fh)
+
+}
+
+sub getReplogInfo {
+ my $self = shift;
+ my ($ldapuri) = @_;
+
+ my %reploginfo;
+ my $slapdconf = $self->getConfigFromUri($ldapuri);
+ my $counter = 0;
+ my $fh;
+ my $rh_replica;
+
+ if ( ! $slapdconf ) {
+ $logger->error("getReplogInfo: no Slapd config file specification in LDAP URI");
+ return undef;
+ } else {
+ open( $fh, "<$slapdconf" ) ||
+ $logger->logdie("Couldn't open Slapd.conf file $slapdconf");
+
+ while ( my $line = <$fh> ) {
+ if ( $line =~ /^\s*replica\s+(.*)/ ) {
+# print "Found replica statement in configfile\n";
+ my $hostport;
+ ($hostport, $rh_replica) = $self->getReplicaInfo( $1, $fh );
+ if ( $hostport ) {
+ if ( ! $rh_replica ) {
+ $logger->error("Missing replica info for host
+ $hostport");
+ }
+ else {
+ $logger->info ("Found replicastatement for host
+ $hostport");
+ $reploginfo{replica}{$hostport} = $rh_replica;
+ }
+ }
+ else {
+ $logger->error("Missing hostport in replica info");
+ }
+
+ }
+ elsif ($line =~ /^\s*replogfile\s+(.*)/) {
+ $reploginfo{replogfile} = $1;
+ }
+ }
+ close $fh;
+# print Dumper(%reploginfo);
+
+ }
+
+
+ return(\%reploginfo);
+
+}
+
+
+sub getReplicaInfo {
+ my $self = shift;
+ my ($string, $fh) = @_;
+
+ ### From slurp config.c:
+ #* Parse a "replica" line from the config file. replica lines should be
+ #* in the following format:
+ #* replica host=<hostname:portnumber> binddn=<binddn>
+ #* bindmethod="simple" credentials=<creds>
+ #*
+ #* where:
+ #* <hostname:portnumber> describes the host name and port number where the
+ #* replica is running,
+ #*
+ #* <binddn> is the DN to bind to the replica slapd as,
+ #*
+ #* bindmethod is "simple", and
+ #*
+ #* <creds> are the credentials (e.g. password) for binddn. <creds> are
+ #* only used for bindmethod=simple.
+ #*
+ #* The "replica" config file line may be split across multiple lines. If
+ #* a line begins with whitespace, it is considered a continuation of the
+ #* previous line.
+
+ my $line = " ";
+ my $cursor = tell($fh);
+ my $replicastr = $string;
+ my %replica;
+
+ while ( $line = <$fh> ) {
+ if ( $line =~ /^\s/ ) {
+ $replicastr .= $line;
+ $cursor = tell($fh);
+ } else {
+ seek ($fh, $cursor, 0);
+ last;
+ }
+ }
+# print "replicastring: [$replicastr]\n";
+ $replicastr =~ s/=\"([^ ]+) ([^ ]+)\"/=\"$1%20$2\"/;
+# print "now: [$replicastr]\n";
+
+ my @replicalines = split /\s+/,$replicastr;
+ my $hostport;
+ my $schema;
+
+ foreach (@replicalines) {
+# print "analysing line: [$_]\n";
+ my ( $attr, $val) = split /=/, $_, 2;
+ $val =~ s/^\"//;
+ $val =~ s/\"$//;
+ $val =~ s/%20/ /;
+ if ( $attr eq 'host' ) {
+ $hostport = $val;
+ my ($host, $port ) = split /:/, $val, 2;
+ $replica{host} = $host;
+ $replica{port} = $port;
+ }
+ elsif ( $attr eq 'uri' ) {
+ ( $schema, $hostport) = split m{://}, $val, 2;
+ my ($host, $port ) = split /:/, $hostport, 2;
+ $replica{schema} = $schema;
+ $replica{host} = $host;
+ $replica{port} = $port;
+ }
+ else {
+# print "$attr = $val\n";
+ $replica{$attr} = $val;
+ }
+ }
+
+# $line = readline($fh);
+# print "next line is [$line]\n";
+# print "returning hostport: [$hostport]\n";
+ return ($hostport, \%replica);
+}
+
+
+sub getReplogFileFromConfigFromUri {
+ my $self = shift;
+ my ($ldapuri) = @_;
+ my $configfilename = $self->getConfigFromUri($ldapuri);
+
+ print "found configfile: $configfilename\n";
+
+
+
+# print "found replogfile: $replogfilename\n";
+
+ return ($configfilename);
+
+}
+
+sub getConfigFromUri {
+ my $self = shift;
+ my ($ldapuri) = @_;
+
+ if ( $ldapuri) {
+# print "getconfig from uri: $ldapuri\n";
+ my $rh_ldapserver = $self->defineServerFromURI($ldapuri, 'notoken');
+ return $rh_ldapserver->{configfile};
+ }
+ else {
+# print "no URI in getConfigFromURI!!!\n";
+ return "";
+ }
+
+}
+
+
+sub initLdifFile {
+ my $self = shift;
+
+ my ($ldif_file, $mode) = @_;
+
+ my $ldif = Net::LDAP::LDIF->new( $ldif_file, $mode, onerror => 'undef' );
+
+ die "Couldn't init LDIF file for mode $mode" unless $ldif;
+
+ return ($ldif);
+}
+
+
+
+sub loadValuesFromLdap {
+ my $self = shift;
+ my ( $ra_list, $uri, $attr, $token, $filter ) = @_;
+
+ $logger->debug("loading values $attr from Server $uri");
+# print "loading values $attr from Server $uri\n";
+ if ( $filter) {
+ $uri = $self->insertFilterInUri($uri, $filter);
+ $logger->debug("added filter to uri: $uri");
+# print "added filter to uri: $uri\n";
+ }
+
+ my $rh_ldapserver =
+ $self->defineServerFromURI($uri, $token, 0);
+
+ $rh_ldapserver->{attribs} = [ $attr ];
+
+ my $ldap = $self->connectServer($rh_ldapserver, 1);
+ if ( ! $ldap ) {
+ $logger->logdie("Could not connect to Server $$rh_ldapserver{host}:".
+ "$$rh_ldapserver{port}!");
+ }
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+ if ($mesg->entries) {
+# print "found ".$mesg->entries." entries now lets see about the $attr\n";
+ $logger->info("Found ".$mesg->entries." entries");
+ my $entry_found;
+ foreach $entry_found ($mesg->all_entries) {
+# print "Found entry ".$entry_found->dn."\n";
+ my @values = $entry_found->get_value( $attr );
+ if ( $values[0] ) {
+# print "adding values to unique list [@values]\n";
+# $logger->debug ("adding values to unique list [@values]");
+ push @{$ra_list}, @values;
+ }
+ }
+ } else {
+ $logger->warn("No entries found");
+# print "No entries found\n";
+ }
+
+ $ldap->unbind;
+
+}
+
+sub getValueFromUri {
+ my $self = shift;
+ my ( $uri, $valuetype) = @_;
+
+ my $value = "";
+
+ if ( $valuetype eq "attributes" ) {
+ if ( $uri =~ /^[^?]*?\?([^?]+?)\?.*$/ ) {
+ $value = $1;
+ } else {
+ $logger->warn("URI part $valuetype missing in LDAP URI");
+ }
+ } else {
+ $logger->logdie("LDAP: getValueFromUri called with unknown valuetype");
+ }
+
+ return($value);
+}
+
+sub defineServerFromReplicaHash {
+ my $self = shift;
+ my ( $rh_server ) = @_;
+ my $rh_ldapdef = $self->defineServer( $rh_server->{schema},
+ $rh_server->{host},
+ $rh_server->{port},
+ undef,
+ $rh_server->{binddn},
+ $rh_server->{credentials},
+ );
+ ### todo bindmethod and other replica parameters
+
+ return ($rh_ldapdef);
+}
+
+
+sub defineServerFromURI {
+ my $self = shift;
+ my ( $uri, $pwtoken,
+ $sizelimit, $timelimit, $deref, $is_typesonly, $rootpw ) = @_;
+
+## URI format: ldap://<host>[:<port>]/<basedn>?<attributes>?<scope>?<filter>?<extension>
+
+ if ( ! $pwtoken ) {
+ $logger->error("Call of defineServerFromURI with no token!");
+ }
+ else {
+ if ( ! $uri ) {
+ $logger->error("Call of defineServerFromURI with no uri! (token: $pwtoken) ");
+ }
+ else {
+ $logger->debug("Defining LDAP server from [$uri] ($pwtoken)");
+ }
+ }
+ my $schema;
+
+# if ( ! ( $uri =~ s{^(ldaps?)://(.*)}{$2}) ) {
+ if ( ! $uri || ! ( $uri =~ m{^(ldaps?)://(.*)}) ) {
+ my $str = $uri ? $uri : "[no uri]";
+ $logger->logdie("uri has to start with 'ldap://' I got: $str");
+ }
+ ($schema, $uri) = split m{://}, $uri;
+
+#print "schema: [$schema], rest of uri: [$uri]\n";
+
+ my ( $hostport, $params ) = split /\//, $uri, 2;
+ my ( $host, $port ) = split /:/, $hostport;
+
+ my ($basedn,$attribs,$scope,$filter,$extensionstring);
+ my $bindname = '';
+ my $credentials = '';
+ my $configfile;
+ my $searchattr;
+
+ my @attributes = undef;
+
+ if ( $params ) {
+ ($basedn,$attribs,$scope,$filter,$extensionstring) =
+ split /\?/, $params;
+
+ if ($attribs) {
+ @attributes= split /,/, $attribs;
+ }
+
+
+ if ( $basedn ) {
+ $basedn =~ s/%2c/,/g;
+ }
+ }
+
+
+#print "Bindname is: $bindname\n";
+#print "ldap://$host:$port/$basedn?$attribs?$scope?$filter?$extension\n";
+
+### defaults:
+# if ( ! $port ) { $port = 389; }
+# if ( ! $scope ) { $scope = "sub"; }
+# if ( ! $filter ) { $filter = "(objectclass=*)"; }
+# if ( ! $sizelimit ) { $sizelimit = 0; }
+# if ( ! $timelimit ) { $timelimit = 389; }
+# if ( ! $deref ) { $deref = 0; }
+# if ( ! $is_typesonly ) { $is_typesonly = 0; }
+
+ my $rh_ldapdef = $self->defineServer( $schema, $host, $port, 3,
+ $bindname, $credentials,
+ $basedn, $scope, \@attributes,
+ $filter, $sizelimit, $timelimit,
+ $deref, $is_typesonly, undef,
+ $configfile, $searchattr);
+
+
+ if ( $extensionstring ) {
+ $self->defineServerExtensions($rh_ldapdef, $extensionstring,
+ $pwtoken, $rootpw);
+ }
+
+
+ return ($rh_ldapdef);
+}
+
+
+sub defineServerExtensions {
+ my $self = shift;
+ my ($rh_ldapdef, $extensionstring, $pwtoken, $rootpw) = @_;
+# print "\nextensionstring: [$extensionstring]\n";
+
+ my @extensions = split /;/, $extensionstring;
+
+ my @allowedextensions = qw/ bindname searchattr userbase userattribute
+ rolebase roleattribute rolememberattribute tls userfilter rolefilter
+ config rootdn/;
+
+ foreach my $extension ( @extensions ) {
+# print "Checking extension: $extension\n";
+ my $is_found = 0;
+ foreach my $allowed ( @allowedextensions ) {
+# print " Checking allowed: $allowed\n";
+
+ if ( $extension =~ /^$allowed=(.*)$/ ) {
+ my $value = $1;
+ $value =~ s/%2c/,/g;
+ $rh_ldapdef->{$allowed} = $value;
+ $is_found = 1;
+# print "found allowed extesnion: $allowed\n";
+ }
+ }
+
+ if ( ! $is_found ) {
+ $logger->logdie("Wrong extension [$extension]. The only allowed extensions in LDAP URI are: @allowedextensions ");
+ }
+
+ }
+
+
+ if ( $rh_ldapdef->{bindname} && $pwtoken ne 'notoken' ) {
+ if (! $pwtoken ) {
+ $logger->error("Cannot retrieve Password for bindname from passwordfile");
+ }
+ else {
+ $rh_ldapdef->{credentials} = $data->getSecret($pwtoken);
+ }
+ }
+
+ if ( $rh_ldapdef->{rootdn} && $rootpw ) {
+ $rh_ldapdef->{rootpw} = $rootpw;
+ }
+
+ return ($rh_ldapdef);
+
+}
+
+
+sub defineServerTLS {
+ my $self = shift;
+ my ($rh_ldapdef, $is_tls, $tls_cafile, $tls_verify,
+ $binddn, $bindpw, $tls_cypher ) = @_;
+ $logger->info("defineServerTLS: starting");
+
+
+ $rh_ldapdef->{is_tls} = $is_tls ? $is_tls : 0;
+ $rh_ldapdef->{tls_cafile} = $tls_cafile ? $tls_cafile : '';
+ $rh_ldapdef->{tls_verify} = $tls_verify ? $tls_verify : 'none';
+ $rh_ldapdef->{tls_cypher} = $tls_cypher ? $tls_cypher : '';
+ $rh_ldapdef->{binddn} = $binddn ? $binddn : '';
+ $rh_ldapdef->{credentials} = $bindpw ? $bindpw : '';
+
+
+ return ($rh_ldapdef);
+
+}
+
+
+sub defineServer {
+ my $self = shift;
+ my ( $schema, $host, $port, $version, $binddn, $credentials, $basedn,
+ $scope, $ra_attribs, $filter, $sizelimit, $timelimit, $deref,
+ $is_typesonly, $rf_callback, $configfile, $searchattr, $is_tls,
+ $tls_cafile, $tls_verify ) = @_;
+
+
+ my %ldapdef;
+ $ldapdef{schema} = $schema ? $schema : 'ldap';
+ $ldapdef{host} = $host ? $host : 'localhost';
+ $ldapdef{port} = $port ? $port : 389;
+ $ldapdef{version} = $version ? $version : 3;
+ $ldapdef{binddn} = $binddn;
+ $ldapdef{credentials} = $credentials;
+ $ldapdef{basedn} = $basedn;
+ $ldapdef{scope} = $scope ? $scope : 'sub';
+ $ldapdef{attribs} = $$ra_attribs[0] ? $ra_attribs : ['*'];
+ $ldapdef{filter} = $filter ? $filter : '(objectclass=*)';
+ $ldapdef{sizelimit} = $sizelimit ? $sizelimit : 0;
+ $ldapdef{timelimit} = $timelimit ? $timelimit : 0;
+ $ldapdef{deref} = $deref ? $deref : 'find';
+ $ldapdef{is_typesonly} = $is_typesonly ? $is_typesonly : 0;
+ $ldapdef{callback} = $rf_callback ? $rf_callback : '';
+ $ldapdef{configfile} = $configfile ? $configfile : '';
+ $ldapdef{searchattr} = $searchattr ? $searchattr : '';
+ $ldapdef{is_tls} = $is_tls ? $is_tls : 0;
+ $ldapdef{tls_cafile} = $tls_cafile ? $tls_cafile : '';
+ $ldapdef{tls_verify} = $tls_verify ? $tls_verify : 'none';
+
+ return ( \%ldapdef);
+}
+
+sub connectServer {
+ my $self = shift;
+ my ( $rh_ldapdef, $dontforcebind, $isrootbind ) = @_;
+
+ my $uri = "$$rh_ldapdef{schema}://$$rh_ldapdef{host}:$$rh_ldapdef{port}";
+
+ $logger->info("Connecting to $uri");
+# if ( $$rh_ldapdef{schema} eq 'ldaps' ) {
+#
+# }
+# else {
+ my $ldap = Net::LDAP->new( $uri,
+ version => $$rh_ldapdef{version},
+ timeout => $$rh_ldapdef{timelimit} );
+# my $ldap = Net::LDAP->new( $$rh_ldapdef{host},
+# port=>$$rh_ldapdef{port},
+# version => $$rh_ldapdef{version},
+# timeout => $$rh_ldapdef{timelimit} );
+# }
+
+
+# print "after new\n";
+
+ if ( !$ldap ) {
+ $logger->error("ERROR while creating connection to ldap server ".
+ "$$rh_ldapdef{host}:$$rh_ldapdef{port}");
+ print " ERROR while creating connection to ldap server ".
+ "$$rh_ldapdef{host}:$$rh_ldapdef{port} \n";
+ return(undef);
+ }
+
+ if ( $rh_ldapdef->{is_tls} ) {
+ $logger->info("starting TLS ");
+ $logger->debug("verify: $rh_ldapdef->{tls_verify}, cafile: $rh_ldapdef->{tls_cafile} cypher: $rh_ldapdef->{tls_cypher}");
+ my $tlsmesg = $ldap->start_tls ( verify => $rh_ldapdef->{tls_verify},
+ cafile => $rh_ldapdef->{tls_cafile},
+ ciphers => $rh_ldapdef->{tls_cypher});
+ if ( $tlsmesg->code != Net::LDAP::LDAP_SUCCESS ) {
+ $logger->error ( "ERROR in ldap->start_tls: " . $tlsmesg->error );
+ }
+ else {
+ $logger->debug ( "Start_TLS operation succeeded");
+ $logger->info ( "tls cipher: " . $ldap->cipher . "\n" );
+ $logger->info ( "tls certificate: " . $ldap->certificate . "\n" );
+
+ }
+ }
+
+ my ($binddn, $credentials, $isbind);
+
+
+ if ( $isrootbind ) {
+ $binddn = $$rh_ldapdef{rootdn};
+ $credentials = $$rh_ldapdef{rootpw};
+ $isbind=1;
+ }
+ elsif ( $$rh_ldapdef{binddn} || $$rh_ldapdef{bindname} ) {
+
+ $binddn = $$rh_ldapdef{binddn} ? $$rh_ldapdef{binddn} : $$rh_ldapdef{bindname};
+ $credentials = $$rh_ldapdef{credentials};
+ $isbind=1;
+ }
+ else {
+# use Data::Dumper;
+# $logger->info("no binddn found in rh_ldap: ".Dumper($rh_ldapdef));
+ }
+
+ if ( $isbind ) {
+ $logger->info("Binding as $binddn");
+ my $mesg = $ldap->bind( $binddn,
+ password => $credentials,
+ version => $$rh_ldapdef{version} );
+
+ unless ( $mesg->code == Net::LDAP::LDAP_SUCCESS ) {
+ $logger->error("Error in LDAP-Bind: ".$mesg->error);
+ if (! $dontforcebind) {
+ $logger->error("Returning undef instead of ldap connection");
+ $ldap = undef;
+ }
+# print "ERROR ldap->bind: ".$mesg->error." \n\n";
+# DAASIlib::LOG::do_log ('fatal', "ERROR ldap->bind!\n\n" );
+ }
+ }
+# print "returning ldap object\n";
+ return $ldap;
+} # connectServer
+
+
+sub doSearch {
+ my $self = shift;
+ my ( $ldap, $rh_ldapdef ) = @_;
+
+# use Data::Dumper;
+# print Dumper( $rh_ldapdef );
+
+ $logger->info("searching from base: $$rh_ldapdef{basedn} scope $$rh_ldapdef{scope} filter: $$rh_ldapdef{filter} ");
+# $logger->info("retrieve attributes: @{${$$rh_ldapdef{attribs}}} ");
+ if ( $$rh_ldapdef{attribs}) {
+ $logger->info("retrieve attributes: @{$$rh_ldapdef{attribs}} ");
+ } else {
+ $logger->info("retrieve all attributes");
+ }
+ if ( ! $$rh_ldapdef{filter}) {
+ $$rh_ldapdef{filter}="(objectclass=*)";
+ }
+
+# exit();
+ my $mesg = $ldap->search(
+ base => $$rh_ldapdef{basedn},
+ scope => $$rh_ldapdef{scope},
+ filter => $$rh_ldapdef{filter},
+ attrs => $$rh_ldapdef{attribs},
+ deref => $$rh_ldapdef{deref},
+ sizelimit => $$rh_ldapdef{sizelimit},
+ timelimit => $$rh_ldapdef{timelimit},
+ typesonly => $$rh_ldapdef{is_typesonly},
+ callback => $$rh_ldapdef{callback},
+ );
+ if ( $mesg->code == Net::LDAP::LDAP_SUCCESS ) {
+ $logger->info("search performed without error" );
+ } else {
+ $self->logLDAPError($mesg, "search");
+ }
+
+ return ($mesg);
+}
+
+
+sub logLDAPError {
+ my $self = shift;
+ my ( $mesg, $operation, $onscreen ) = @_;
+
+
+ if ( ! $operation) {
+ $operation = "operation";
+ }
+
+ if ( $mesg->code == LDAP_TIMELIMIT_EXCEEDED ||
+ $mesg->code == LDAP_SIZELIMIT_EXCEEDED ||
+ $mesg->code == LDAP_NO_SUCH_OBJECT ||
+ $mesg->error eq "No attributes to update" ) {
+
+ $logger->warn("LDAP $operation errorcode ".$mesg->code.": ".$mesg->error);
+ }
+ elsif ( $mesg->code == LDAP_SUCCESS ) {
+ $logger->info("Result in LDAP $operation: ".$mesg->error
+ ." (".$mesg->code.")");
+ }
+ else {
+ $logger->error("Error ".$mesg->code." in LDAP $operation: ".$mesg->error);
+ }
+ if ( $onscreen) {
+ print " Result in LDAP $operation: ".$mesg->error." (".$mesg->code.")\n";
+ }
+}
+
+sub updateServerFromLDIF{
+ my $self = shift;
+ my ( $filename, $rh_ldapdef, $rewrite ) = @_;
+
+# use Data::Dumper;
+# print Dumper($rh_ldapdef);
+
+
+ my $ldif = $self->initLdifFile($filename,"r");
+ my $ldiferrorfile = "$filename.errors.txt";
+ my $ldiferror = $self->initLdifFile($ldiferrorfile,"w");
+ my $ldiferrorhandle = $ldiferror->handle();
+ my $ldap = $self->connectServer($rh_ldapdef);
+
+ my $mesg;
+ my $entry;
+ my @attribs =();
+ while( not $ldif->eof ( ) ) {
+ $entry = $ldif->read_entry ( );
+ my $dn = $entry->dn();
+ if ( $ldif->error ( ) ) {
+ $logger->error("In LDIF file: ", $ldif->error ( ) );
+ $logger->error("Lines:\n", $ldif->error_lines ( ) );
+ } else {
+ $logger->info("Updating entry ".$entry->dn());
+ $mesg = $entry->update($ldap);
+ unless ( $mesg->code == Net::LDAP::LDAP_SUCCESS ) {
+ if ( $rewrite && $mesg->code == LDAP_ALREADY_EXISTS ) {
+ $logger->warn("entry ($dn)already exists, will rewrite ($rewrite)");
+ if ( $rewrite =~ /^ok_except_(.*)$/ ) {
+ @attribs = split /_/, $1;
+ }
+ my $oldentry = $self->sessionReadEntry($entry->dn(), $ldap,
+ $rh_ldapdef);
+ if (! $oldentry ) {
+ $logger->logdie("Expected entry ($dn) does not exist!");
+ }
+
+ $mesg = $self->updateOldEntry($oldentry, $entry, $ldap,
+ \@attribs);
+ if ( $mesg && $mesg->code != Net::LDAP::LDAP_SUCCESS ) {
+ $logger->error("Error in LDAP update (2nd. try) in entry $dn: ".$mesg->error);
+ }
+ }
+ else {
+ $logger->error("Error in LDAP update of entry $dn: ".$mesg->error);
+ $logger->info("Writing not updated entry to $ldiferrorfile");
+ print $ldiferrorhandle
+ "\n# Error in LDAP update: ".$mesg->error;
+ $ldiferror->write_entry($entry);
+ }
+ }
+ }
+ }
+ $ldap->unbind if $ldap;
+ $ldif->done ( );
+ $ldiferror->done ( );
+ return ($mesg);
+}
+
+sub createDnFromObject {
+ my $self = shift;
+ my ( $rh_object, $be_stupid ) = @_;
+ my $dn = "";
+
+ my $rdnattr = $rh_object->{classinfo}{rdnattr};
+ my $rdnattr_lc = lc($rdnattr);
+
+ my $basedn = $rh_object->{classinfo}{basedn};
+
+# print "basedn: $basedn\n";
+ while ( $basedn =~ /(.*?)#\((.+?)\)(.*)/ ) {
+ my $before = $1;
+ my $attr = $2;
+ $logger->debug("adding val from attribute $attr");
+ my $val = $rh_object->{attributes}{$attr}[0];
+ if ( $val) {
+ $logger->debug("found val $val from attribute $attr");
+ }
+ else {
+ $logger->error("Couln't find any value in Attribute $attr");
+ }
+ my $after = $3;
+ $basedn = "$before$val$after";
+ }
+
+
+ if ( $rh_object->{attributes}{$rdnattr}[0] ) {
+ $dn = "$rdnattr=".
+ "$rh_object->{attributes}{$rdnattr}[0],".
+ "$basedn";
+ }
+ elsif ( $rh_object->{attributes}{$rdnattr_lc}[0] ) {
+ $dn = "$rdnattr=".
+ "$rh_object->{attributes}{$rdnattr_lc}[0],".
+ "$basedn";
+ }
+ else {
+ if ($be_stupid) {
+ $dn = "$rdnattr=XXX,$basedn";
+ }
+ else {
+ $logger->error("Couldn't create DN: RDN attribute $rdnattr has no value");
+
+ use Data::Dumper;
+ $logger->debug(Dumper($rh_object->{attributes}));
+ }
+ }
+
+ return ($dn);
+}
+
+
+## Not really used in dbconnector project:
+sub createDiffEntry {
+ my $self = shift;
+ my ( $oldentry, $newentry ) = @_;
+
+ if ( ! $newentry ) {
+ print "createDiffEntry called with no newentry\n";
+ return;
+ }
+ if ( ! $oldentry ) {
+ print "createDiffEntry called with no newentry\n";
+ return;
+ }
+
+ my $diffentry = $oldentry->clone();
+
+
+# my $is_change;
+# my $is_newvalue;
+
+ foreach my $attr ( $newentry->attributes ) {
+ my @values = $newentry->get_value( $attr );
+ if ( $values[0] ) {
+ my @oldvalues = $oldentry->get_value( $attr );
+ my @newvalues = $data->findNewValues(\@values, \@oldvalues );
+# print "testing whether newvalues [@values] of attribute $attr do not exist in old values [@oldvalues]\n";
+ if ( @newvalues ) {
+ $diffentry->add($attr => @newvalues );
+ }
+ }
+ }
+
+ return ($diffentry);
+}
+
+# An alternative from ldifdiff.pl: ($Id: ldifdiff.pl,v 3.7 2005/03/15 14:22:45 subbarao Exp $)
+# Generate LDIF to update $target with information in $source.
+# Optionally restrict the set of attributes to consider.
+sub updateFromEntry
+{
+ my $self = shift;
+ my ($source, $target, @attrs) = @_;
+ my ($attr, $val, $ldifstr);
+
+ my @sourceattrs;
+ my (%ciscmp, %dnattrs, %sharedattrs);
+ my $keyattr;
+# GetOptions('a|sourceattrs=s' => sub { @sourceattrs = split(/,/, $_[1]) },
+# 'c|ciscmp=s' => sub { my @a = split(/,/,lc $_[1]); @ciscmp{@a} = (1) x @a },
+# 'dnattrs=s' => sub { my @a = split(/,/,lc $_[1]); @dnattrs{@a} = (1) x @a },
+# 'k|keyattr=s' => \$keyattr,
+# 'sharedattrs=s' => sub {my @a=split(/,/,lc $_[1]);@sharedattrs{@a}=(1) x @a}
+# );
+ %ciscmp = (objectclass => 1, manager => 1, member => 1, owner => 1,
+ uniquemember => 1)
+ unless keys %ciscmp;
+ %dnattrs = (manager => 1, member => 1, owner => 1, uniquemember => 1)
+ unless keys %dnattrs;
+ %sharedattrs = (objectclass => 1)
+ unless keys %sharedattrs;
+
+
+
+ unless (@attrs) {
+ # add all source entry attributes
+ @attrs = $source->attributes;
+ # add any other attributes we haven't seen from the target entry
+ foreach my $tattr ($target->attributes) {
+ push(@attrs, $tattr) unless grep(/^$tattr$/i, @attrs);
+ }
+ }
+
+ $target->{changetype} = 'modify';
+
+ foreach $attr (@attrs) {
+ my $lcattr = lc $attr;
+ next if $lcattr eq 'dn'; # Can't handle modrdn here
+
+ # Build lists of unique values in the source and target, to
+ # speed up comparisons.
+ my @sourcevals = $source->get_value($attr);
+ my @targetvals = $target->get_value($attr);
+ my (%sourceuniqvals, %targetuniqvals);
+ foreach (@sourcevals) {
+ my ($origval, $val) = ($_, $_);
+ $val = lc $val if $ciscmp{$lcattr};
+ # Get rid of spaces after non-escaped commas in DN attrs
+ $val =~ s/(?<!\\),\s+/,/g if $dnattrs{$lcattr};
+ $sourceuniqvals{$val} = $origval;
+ }
+ foreach (@targetvals) {
+ my ($origval, $val) = ($_, $_);
+ $val = lc $val if $ciscmp{$lcattr};
+ # Get rid of spaces after non-escaped commas in DN attrs
+ $val =~ s/(?<!\\),\s+/,/g if $dnattrs{$lcattr};
+ $targetuniqvals{$val} = $origval;
+ }
+ foreach my $val (keys %sourceuniqvals) {
+ if (exists $targetuniqvals{$val}) {
+ delete $sourceuniqvals{$val};
+ delete $targetuniqvals{$val};
+ }
+ }
+
+ # Move on if there are no differences
+ next unless keys(%sourceuniqvals) || keys(%targetuniqvals);
+
+ # Make changes as appropriate
+ if ($sharedattrs{$lcattr}) {
+ # For 'shared' attributes (e.g. objectclass) where $source may not
+ # be a sole authoritative source, we issue separate delete and
+ # add modifications instead of a single replace.
+ $target->delete($attr => [ values(%targetuniqvals) ])
+ if keys(%targetuniqvals);
+ $target->add($attr => [ values(%sourceuniqvals) ])
+ if keys(%sourceuniqvals);
+ }
+ else {
+ # Issue a replace or delete as needed
+ if (@sourcevals) { $target->replace($attr => [ @sourcevals ]) }
+ else { $target->delete($attr) }
+ }
+ }
+
+
+# my $is_changed = 1;
+ # Get rid of the "changetype: modify" if there were no changes
+ if ( ! @{$target->{changes}} ) {
+ delete($target->{changetype}); # unless @{$target->{changes}};
+# $is_changed = 0;
+ }
+
+# return ( $is_changed );
+}
+
+
+
+sub createEntryFromObject {
+ my $self = shift;
+ my ( $rh_object, $excludepattern, $be_stupid ) = @_;
+
+ my $entry = undef;
+
+ my $dn = $self->createDnFromObject($rh_object, $be_stupid);
+
+ if ( $dn ) {
+ my @attributenames;
+ @attributenames = $data->makeUnique(@{$rh_object->{attributenames}});
+
+ if ($excludepattern) {
+ @attributenames = $data->removeElements(\@attributenames, $excludepattern);
+ }
+
+ $entry = Net::LDAP::Entry->new;
+ $entry->dn($dn);
+ $entry->add( "objectClass" => $rh_object->{classes} );
+
+ foreach my $field ( @attributenames ) {
+ if ( @{$rh_object->{attributes}{$field}}[0] ) {
+ $entry->add ( $field => $rh_object->{attributes}{$field});
+ }
+ }
+
+ }
+ else {
+ $logger->error("Couldn't create DN in createEntryFromObject");
+ print "Couldn't create DN in createEntryFromObject\n";
+ }
+
+ return ($entry);
+}
+
+sub printEntry {
+ my $self = shift;
+ my ( $entry, $fp, $is_nodn) = @_;
+
+ if ( ! $is_nodn ) {
+ print $fp "dn: ", $entry->dn(), "\n";
+ }
+ foreach my $attr ( $entry->attributes ) {
+ foreach my $value ( $entry->get_value( $attr ) ) {
+ if ( $value =~ /[^\x20-\x7f]/ ) {
+# use MIME::Base64;
+#
+# $encoded = encode_base64('Aladdin:open sesame');
+# $decoded = decode_base64($encoded);
+ my $encvalue = encode_base64($value);
+
+ if ( $encvalue ) {
+ print $fp "#encoded: $attr: $value\n";
+ print $fp "${attr}:: $encvalue";
+ }
+ else {
+ print "something is strange with value $value\n"
+ }
+
+ }
+ else {
+ print $fp "${attr}: $value\n";
+ }
+ }
+ }
+ print $fp "\n";
+}
+
+sub stringifyEntry {
+ my $self = shift;
+ my ( $entry, $prefix) = @_;
+
+ my $entrystring;
+
+ my $dn = $entry->dn();
+
+ $entrystring = $self->stringify("dn: $dn\n", $prefix);
+
+ foreach my $attr ( $entry->attributes ) {
+ foreach my $value ( $entry->get_value( $attr ) ) {
+ if ( $value =~ /[^\x20-\x7f]/ ) {
+# use MIME::Base64;
+#
+# $encoded = encode_base64('Aladdin:open sesame');
+# $decoded = decode_base64($encoded);
+ my $encvalue = encode_base64($value);
+
+ $entrystring .=
+ $self->stringify("#encoded: $attr: $value\n",
+ $prefix);
+ $entrystring .=
+ $self->stringify("${attr}:: $encvalue",$prefix);
+ }
+ else {
+ $entrystring .=
+ $self->stringify("${attr}: $value\n",$prefix);
+ }
+ }
+ }
+ $entrystring .= $self->stringify("\n",$prefix);
+
+ return ($entrystring);
+}
+
+sub stringify {
+ my $self = shift;
+ my ( $string, $prefix) = @_;
+
+ if ( $prefix ) {
+ return("${prefix}$string");
+ }
+ else {
+ return ($string);
+ }
+
+}
+
+sub readEntryFromUri {
+ my $self = shift;
+ my ( $dn, $uri, $uripwtoken ) = @_;
+
+ my $rh_ldapserver = $self->defineServerFromURI($uri, $uripwtoken, 0);
+
+ $rh_ldapserver->{scope} = "base";
+ $rh_ldapserver->{basedn} = $dn;
+# if ( $rh_ldapserver->{binddn} ) {
+# $rh_ldapserver->{credentials} = $data->getSecret($uripwtoken);
+# }
+
+ my $ldap = $self->connectServer($rh_ldapserver);
+# print "base search with bas = $dn\n";
+
+ my $entry = sessionReadEntry($dn,$ldap, $rh_ldapserver);
+
+# my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+# my $entry = undef;
+# if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->entries == 1) {
+# $entry = $mesg->pop_entry();
+# } else {
+# $logger->warn("Entry $dn not found");
+
+# print "Entry $dn not found\n";
+# }
+
+ return $entry;
+}
+
+
+# if ($rh_output_object->{operationalattributes}{is_modifyentry}) {
+
+# print "OK now compare what we have got with the corresponding LDAP enntry\n";
+# use Data::Dumper;
+# print Dumper(%{$$rh_output_object});
+# my $rdnattr = $rh_output_object->{classinfo}{rdnattr};
+#
+# if ( $is_ldap_output &&
+# $rh_output_object->{attributes}{$rdnattr}[0] ) {
+#
+# my $dn = "$rdnattr=".
+# "$rh_output_object->{attributes}{$rdnattr}[0],".
+# "$rh_output_object->{classinfo}->{basedn}";
+# print "searching DN: $dn at:\n";
+# print " $conf->{data}{outputuri}\n";
+
+
+
+sub findModificationsFromLDAP {
+ my $self = shift;
+ my ($newentry, $ldap, $rh_ldapserver,$ra_attributes ) = @_;
+
+ my $entry;
+ my $is_changes = 0;
+
+# my $oldentry = $self->sessionReadEntry($dn,$ldap, $rh_ldapserver);
+ my $oldentry = $self->sessionSearchEntry($ldap, $rh_ldapserver);
+
+# use Data::Dumper;
+# print Dumper($newentry);
+
+
+ if ( $oldentry ) {
+
+ $logger->debug("Found old entry to modify\n");
+# print "findModificationsFromLDAP calling findModifications\n";
+ ($is_changes, $entry) = $self->findModifications("MOD", $oldentry, $newentry,
+ $ra_attributes);
+# print "back in findModificationsFromLDAP with entry",$entry->dn(),"\n";
+# print Dumper ($oldentry);
+ $entry->changetype("modify");
+ } else {
+ $entry = $newentry;
+ $is_changes = 1;
+ $entry->changetype("add");
+ }
+
+# print Dumper($entry);
+# exit();
+
+ return($is_changes, $entry);
+}
+
+sub findModifications {
+ my $self = shift;
+ my ($mode, $oldentry, $newentry, $ra_attributes) = @_;
+
+ my $diffentry= $oldentry;
+ my $is_change;
+ my $is_newvalue;
+
+# use Data::Dumper;
+# print Dumper($diffentry);
+
+# $logger->debug("findModifications called with attributes: ".
+# "@{$ra_attributes}");
+# print "findModifications called with attributes: @{$ra_attributes}";
+# print Dumper($newentry);
+# exit();
+ foreach my $attr ( $newentry->attributes ) {
+ $is_change = 0;
+ $is_newvalue = 0;
+ my @values = $newentry->get_value( $attr );
+ if ( $ra_attributes ) {
+ if ( grep { $attr eq $_} @{$ra_attributes} ) {
+ if ( $values[0] ) {
+ $is_newvalue = 1;
+ }
+ }
+ } else {
+ if ( $values[0] ) {
+ $is_newvalue = 1;
+ }
+ }
+
+
+
+ if ($is_newvalue ) {
+ my @oldvalues = $oldentry->get_value( $attr );
+
+ my @newvalues = $data->findNewValues(\@values, \@oldvalues );
+# print "testing whether newvalues [@values] of attribute $attr do not exist in old values [@oldvalues]\n";
+ if ( @newvalues ) {
+ $is_change = 1;
+# print " the values really seem to be new!\n";
+ $logger->debug("findmodifications found something to modify ($mode) in attr: $attr=@newvalues");
+
+# print "Adding new values to old entry (mode $mode):\n";
+# foreach (@values) {
+# print " [$_]\n";
+# }
+
+ if ($mode eq "MOD") {
+ $diffentry->replace ( $attr => @newvalues );
+ } elsif ($mode eq "ADD") {
+ $diffentry->add ( $attr => @newvalues );
+ } elsif ($mode eq "DEL") {
+# $diffentry->delete ( $attr => @newvalues );
+# $diffentry->delete ( $attr );
+ # deletes will be handled later
+ }
+ }
+ }
+# print "Juhu\n";
+ }
+# $diffentry->changetype("modify");
+# print Dumper($diffentry);
+# exit();
+ return ($is_change, $diffentry);
+}
+
+
+
+sub updateEntry {
+ my $self = shift;
+ my ($entry, $ldap) = @_;
+
+ my $mesg = undef;
+
+# print "updateEntry calling entry-update on entry ", $entry->dn(),"\n";
+# use Data::Dumper;
+# print Dumper ($entry);
+# print Dumper ($ldap);
+
+ $mesg = $entry->update($ldap);
+ # This is a temporary patch, until we know if there is something
+ # wrong in module Net::LDAP::Entry (patched line 253 of version 0.20)
+# {
+# my %changes ;
+# foreach my $attr ($entry->attributes( nooptions => 1 )) {
+# my [at]values = $entry->get_value($attr) ;
+# $changes{$attr} = [at]values == 1? $values[0]: \@values ;
+# }
+# $msg = $ldap->modify($entry,replace => \%changes) ;
+# }
+
+# print "Hi there\n";
+ if ( $mesg->code != LDAP_SUCCESS ) {
+# print "Error in Update: ".$mesg->code.":".$mesg->error."\n";
+ $self->logLDAPError($mesg, "updateEntry");
+ }
+ return ( $mesg->code );
+
+}
+
+sub updateOldEntry {
+ my $self = shift;
+ my ($oldentry, $newentry, $ldap, $ra_attribs) = @_;
+
+ my %nonoattribs;
+
+ foreach my $e ( @{$ra_attribs}) {
+ $logger->debug("attribute $e will be ignored");
+ $nonoattribs{lc($e)}++;
+ }
+
+ my $is_change = 0;
+ my $mesg;
+ $oldentry->changetype('modify');
+ foreach my $attr ( $newentry->attributes ) {
+ if ( ! $nonoattribs{lc($attr)} ) {
+ my @vals = $newentry->get_value($attr);
+ my @oldvals = $oldentry->get_value($attr);
+ my $is_casesensitive = lc($attr) eq 'objectclass' ? 0 : 1;
+
+ if ( $data->areTheyDifferent(\@vals,\@oldvals, $is_casesensitive) ) {
+ $oldentry->replace( $attr => \@vals );
+ $is_change++;
+ $logger->debug("change in attr $attr: @vals (oldvals: @oldvals");
+ }
+ }
+ }
+
+ if ( $is_change ) {
+ $logger->info("Found changes in $is_change values thus updating");
+ $mesg = $oldentry->update($ldap);
+ }
+ else {
+ $logger->warn("no changes found");
+# $mes->g = Net::LDAP::LDAP_SUCCESS;
+ $mesg = undef;
+ }
+
+ return ($mesg);
+}
+
+sub authenticateUser {
+ my $self = shift;
+ my ( $userid, $passw, $rh_ldapserver, $uidattr, $noneed2bind ) = @_;
+
+ my $result = undef;
+ my $entry = undef;
+# my $errortext;
+
+ if ( !$uidattr) { $uidattr = 'uid';}
+
+ $rh_ldapserver->{filter} = "($uidattr=$userid)";
+ $logger->info("starting connectServer");
+ my $ldap= $self->connectServer($rh_ldapserver, 0);
+ if ( ! $ldap ) {
+ $logger->error("authenticateUser() failed");
+ return undef;
+ }
+
+ $logger->info("starting doSearch");
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+
+
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->count == 1) {
+ $logger->info("found exactly one entry");
+ $entry = $mesg->pop_entry();
+ if ( $noneed2bind ) {
+ $result = $entry->dn;
+ }
+ else {
+ $logger->info("starting bind with ".$entry->dn);
+ $mesg = $ldap->bind( $entry->dn,
+ password => $passw,
+ version => $rh_ldapserver->{version} );
+
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS) {
+ $result = $entry->dn;
+ }
+ else {
+ $logger->warn("Bind with ".$entry->dn()." not successfull: "
+ .$mesg->code);
+ }
+ }
+ } else {
+
+ $logger->warn("result of doSearch: ".$mesg->code.'/'.$mesg->error
+ .'/ count: '.$mesg->count);
+
+# $logger->warn("Entry ".$entry->dn." not found");
+ }
+ $ldap->unbind;
+
+ return ($result);
+}
+
+sub sessionReadEntry {
+ my $self = shift;
+ my ( $dn, $ldap, $rh_ldapserver ) = @_;
+
+ $rh_ldapserver->{scope} = "base";
+ $rh_ldapserver->{basedn} = $dn;
+
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+ my $entry = undef;
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->entries == 1) {
+ $entry = $mesg->pop_entry();
+ } else {
+ $logger->warn("Entry $dn not found");
+ }
+ return $entry;
+}
+
+sub sessionSearchSingleEntry {
+ my $self = shift;
+ my ( $ldap, $rh_ldapserver ) = @_;
+
+ my $filter = $rh_ldapserver->{filter};
+# print "xxx\n";
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+ my $entry = undef;
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->entries == 1) {
+# print "xxxa\n";
+ $logger->debug("sessionSearchEntry found one entry");
+ $entry = $mesg->pop_entry();
+ } else {
+# print "xxxb\n";
+
+ $logger->warn("Single entry for filter $filter not found, but "
+ . $mesg->entries . "entries");
+#print "Single entry for filter $filter not found\n";
+ }
+
+# print "zzz\n";
+# exit();
+ return $entry;
+}
+
+
+## bad name will be deleted soon:
+sub sessionSearchEntry {
+ my $self = shift;
+ my ( $ldap, $rh_ldapserver ) = @_;
+
+ my $filter = $rh_ldapserver->{filter};
+
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+ my $entry = undef;
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->entries == 1) {
+ $entry = $mesg->pop_entry();
+ } else {
+ $logger->warn("Single entry for filter $filter not found");
+#print "Single entry for filter $filter not found\n";
+ }
+ return $entry;
+}
+
+
+sub createLDIFFileFromLDAP{
+ my $self = shift;
+ my ( $filename, $rh_ldapdef ) = @_;
+
+ my $returnstr = "";
+# my $libldap = new DAASIlib::LDAP;
+ my $ldap = $self->connectServer($rh_ldapdef);
+
+ if ( ! $ldap ) {
+ $logger->logdie("Could not connect to Server $$rh_ldapdef{host}:".
+ "$$rh_ldapdef{port}!");
+ }
+
+ $logger->info("connected to ".$self->createLdapUri($rh_ldapdef) );
+
+
+# $logger->info("connected to ldap://$$rh_ldapdef{host}:$$rh_ldapdef{port}".
+# "/$$rh_ldapdef{basedn}?".
+# $$rh_ldapdef{attribs} ?
+# join(',', $$rh_ldapdef{attribs}).'?' : '?'.
+# $$rh_ldapdef{scope} ? "$$rh_ldapdef{scope}?" : '?'.
+# $$rh_ldapdef{filter} ? "$$rh_ldapdef{filter}?" : '?'.
+# $$rh_ldapdef{binddn} ? "binddn=$$rh_ldapdef{binddn}" : '');
+# print " * connected to $$rh_ldapdef{host}\n";
+
+ my $mesg = $self->doSearch($ldap, $rh_ldapdef);
+
+ my $ldif = $self->initLdifFile($filename,"w");
+
+ if ($mesg->entries) {
+ $logger->info("Found ".$mesg->entries." entries");
+ my $entry_found;
+ foreach $entry_found ($mesg->all_entries) {
+# print "Found entry ".$entry_found->dn."\n";
+ $ldif->write_entry( $entry_found );
+ }
+ $returnstr=$filename;
+ } else {
+ $logger->warn("No entries found");
+ }
+
+ $ldif->done();
+ $ldap->unbind;
+# $logger->logdie("Exiting now cause code is missing yet");
+
+ return($returnstr);
+}
+
+
+sub createLdapUri {
+ my $self = shift;
+ my ( $rh_ldapdef ) = @_;
+
+ my $uri = "ldap://";
+
+ $uri .= "$$rh_ldapdef{host}:$$rh_ldapdef{port}";
+ $uri .= "/$$rh_ldapdef{basedn}?";
+ $uri .= @{$rh_ldapdef->{attribs}} && @{$rh_ldapdef->{attribs}}[0] ne '*' ?
+ join(',', @{$rh_ldapdef->{attribs}}).'?' : '?';
+ $uri .= $$rh_ldapdef{scope} && $$rh_ldapdef{scope} ne 'sub' ?
+ "$$rh_ldapdef{scope}?" : '?';
+ $uri .= $$rh_ldapdef{filter} && $$rh_ldapdef{filter} ne '(objectclass=*)' ?
+ "$$rh_ldapdef{filter}?" : '?';
+ $uri .= $$rh_ldapdef{binddn} ? "binddn=$$rh_ldapdef{binddn}" : '';
+
+ return $uri;
+
+}
+
+sub readSchemafromServer {
+ my $self = shift;
+ my ( $prot, $host, $port ) = @_;
+ my ($schema, $ldap);
+
+
+ my $rh_ldapdef = $self->defineServer($prot, $host, $port);
+
+ $ldap = $self->connectServer($rh_ldapdef);
+
+ if ( ! $ldap ) {
+ die "Could not connect to Server $host:$port!\n";
+ }
+#print " * connected to $$rh_ldapdef{host}\n";
+
+
+# $ldap = Net::LDAP->new ( $host, port => $port );
+ $schema = $ldap->schema ( );
+# print "loaded schema\n";
+ if ( $schema ) {
+ if ($schema->error() ) {
+### TODO log this
+ print "Error after loading schema: ";
+ print "$schema->error()\n";
+ } else {
+# print "storing schema\n";
+ $self->{schema} = $schema;
+ }
+ } else {
+### TODO log this
+ print "Error couldn't load schema!\n";
+ }
+ my $mesg = $ldap->unbind;
+ print " * disconnecting from $$rh_ldapdef{host}\n";
+
+# print "returning schema\n";
+ return ($schema);
+}
+
+
+sub writeEntry {
+ my $self = shift;
+ my ( $fh, $entry, $changetype ) = @_;
+
+ print $fh ($entry->dn(), "\n");
+ if ( $changetype ) {
+ print $fh "changetype: $changetype\n";
+ }
+
+ foreach my $objectclass ( $entry->get_value('objectClass') ) {
+ print $fh "objectClass: $objectclass\n";
+ }
+
+ foreach my $attr ( $entry->attributes() ) {
+ if ( lc($attr) ne 'objectclass' ) {
+ foreach my $val ( $entry->get_value($attr) ) {
+ print $fh "$attr: $val\n";
+ }
+
+ }
+ }
+
+ print $fh "\n";
+
+
+}
+
+
+sub disconnect {
+ my $self = shift;
+ my ( $ldap ) = @_;
+
+ if ( $ldap ) {
+ my $mesg = $ldap->unbind;
+ }
+ ## if blabla
+}
+
+
+sub readSchema {
+ my $self = shift;
+ my ( $location, $etcdir ) = @_;
+ my $schema;
+# print "readschema: location: |$location| etcdir: |$etcdir|\n";
+ if ( $location =~ /^file:\s*(.+)/ ) {
+ my $file = $1;
+ if ( ! -e $file ) {
+ $file =~ s/\.\/etc\///;
+ $file = "$etcdir/$file";
+ }
+ $schema = $self->readSchemafromFile($file);
+ } elsif ( $location =~ m{^(ldaps?)://\s*(.+):(\d*)} ) {
+ $schema = $self->readSchemafromServer($1,$2, $3);
+ } elsif ( $location =~ m{^(ldaps?)://\s*(.+)} ) {
+ $schema = $self->readSchemafromServer($1,$2,389);
+ } else {
+ if ( ! -e $location ) {
+ $location = "$etcdir/$location";
+ }
+ $schema = $self->readSchemafromFile($location);
+ }
+# print "schema read\n";
+ return ($schema);
+}
+
+sub readSchemafromFile {
+ my $self = shift;
+ my ( $filename ) = @_;
+ my $schema;
+
+ $schema = Net::LDAP::Schema->new;
+ $schema->parse ( $filename ) or die $schema->error;
+ $self->{schema} = $schema;
+ return ($schema);
+}
+
+
+sub superclasses {
+ my $self = shift;
+ my ( $schema, $class ) = @_;
+ my $superclass = $class;
+ my @classes;
+
+# use Data::Dumper;
+# print "Schema: \n";
+# print Dumper($schema);
+
+# print "getting superclasses of *$class*\n";
+
+ push @classes, $class;
+
+# print $schema->superclass($superclass);
+
+ while ( ( $superclass ) = $schema->superclass ($superclass) ) {
+ if ( $superclass ) {
+# print "found super [$superclass]\n";
+ push @classes, $superclass;
+ } else {
+ last;
+ }
+ }
+
+ return (reverse @classes);
+
+}
+
+
+sub getmusts {
+ my $self = shift;
+ my ( $schema, @classes ) = @_;
+
+ my @musts;
+
+ foreach my $class (@classes) {
+ foreach my $must ( $schema->must($class) ) {
+ push @musts , lc($$must{name});
+ }
+ }
+
+ my %seen = ();
+ my @uniq = grep { ! $seen{$_} ++} @musts;
+
+ return(@uniq);
+}
+
+sub getmays {
+ my $self = shift;
+ my ( $schema, @classes ) = @_;
+
+ my @mays;
+
+ foreach my $class (@classes) {
+ foreach my $may ( $schema->may($class) ) {
+ push @mays , lc($$may{name});
+ }
+ }
+
+ my %seen = ();
+ my @uniq = grep { ! $seen{$_} ++} @mays;
+
+ return(@uniq);
+}
+
+sub checkSchema {
+ my $self = shift;
+ my ($schema, $mode, $rh_object) = @_;
+# my ($schema, $ra_classes, $ra_attributenames, $rh_attributes) = @_;
+
+
+ # first check if all classes are known:
+ my $class;
+ my @known_classes = $schema->all_objectclasses;
+ my @classes;
+ my $is_not_ok = 0;
+
+
+ foreach $class ( @known_classes ) {
+# print "Known class: $class->{name}\n";
+ push @classes, $class->{name};
+
+# use Data::Dumper;
+# print Dumper($class);
+# exit();
+ }
+
+ my @clean_classes;
+
+ foreach $class ( @{$$rh_object{classes}} ) {
+ if ( grep { lc($_) eq lc($class) } @classes ) {
+ push @clean_classes, $class;
+ } else {
+### todo log error
+ print " Error in schemacheck: unknown object class $class\n";
+ if ( $mode > 3 ) {
+ $is_not_ok++;
+ }
+ }
+ }
+
+ $$rh_object{classes} = \@clean_classes;
+
+ my @musts = $self->getmusts($schema, @{$$rh_object{classes}});
+ my @mays = $self->getmays($schema, @{$$rh_object{classes}});
+
+# print "Entry has following classes: \n\t@{$$rh_object{classes}}\n";
+# print " with following must attrs: \n\t@musts\n";
+# print " with following may attrs: \n\t@mays\n";
+
+
+ my $may_not_ok = 0;
+ my $must_not_ok = 0;
+
+ push @musts, $$rh_object{classinfo}{rdnattr};
+# print "musts: @musts\n";
+
+ foreach my $must (@musts) {
+ if ( lc($must) eq "objectclass" ) { next;}
+ if ( ! $$rh_object{attributes}{$must} ) {
+### todo log error
+ print "Error in schemacheck: missing must: $must\n";
+ if ( $mode <= 3 ) {
+ $$rh_object{attributes}{$must}[0] =
+ "value added by dbconnector";
+ push @{$$rh_object{attributenames}}, $must;
+ } else {
+ $must_not_ok++;
+ }
+ }
+ }
+
+ if ( $must_not_ok ) { $is_not_ok++; }
+
+ push @mays, @musts;
+ foreach my $attr ( keys %{$$rh_object{attributes}} ) {
+ if ( ! grep { $attr eq $_ } @mays ) {
+ if ( $mode == 3 ) {
+ delete $$rh_object{attributes}{$attr};
+ print "Error in schemacheck: not allowed Attribute $attr ".
+ "deleted\n";
+ } else {
+### todo log error
+ print "Error in schemacheck: Attribute $attr not allowed\n";
+ $may_not_ok++;
+ }
+ }
+ }
+
+ if ( $may_not_ok ) {
+ if ( $mode == 1 ) {
+ push @{$$rh_object{classes}}, "attrObject";
+ } elsif ( $mode == 2 ) {
+ push @{$$rh_object{classes}}, "extensibleObject";
+ } elsif ( $mode == 4 ) {
+ $is_not_ok++;
+ }
+
+ }
+
+### TODO check attribute syntaxes
+
+# use Data::Dumper;
+# print Dumper($rh_object);
+
+ return ($is_not_ok);
+
+}
+
+
+sub getrdn {
+ my $self = shift;
+ my ($dn) = @_;
+ use Data::Dumper;
+
+ use Net::LDAP::Util qw( ldap_explode_dn);
+ my $ra_rdns = ldap_explode_dn($dn);
+ my ($key, $val) = each %{@{$ra_rdns}[0]} ;
+ if ( each %{@{$ra_rdns}[0]} ) {
+ $logger->error("multivalued rdns not yet supported");
+ }
+
+#- print "key: [$key] val: [$val]\n";
+ my $rdn = "$key=$val";
+
+ return ($rdn);
+}
+
+
+sub clean_errormessage {
+ my $self = shift;
+ my ($errormesg) = @_;
+# print "error: \n|$errormesg|\n";
+ $errormesg =~ s/\x00//;
+ chomp($errormesg);
+ return($errormesg);
+}
+
+
+
+# -------------------------------------------------------------------------------------------------
+# Name: moveDn
+# Eingabe: inConnection (Handler) / Ein LDAP-Verbindungs-Handler
+# inSourceDn (string) / Eine DN, die verschoben werden soll
+# inNewDn (string) / Das Ziel, wohin verschoben werden soll
+# inRecursive (boolean) / Rekursiver Aufruf der Funktion
+# Funktion: Verschiebt einen DN in einen anderen Teilbaum, bei Angabe von inRecursive auch rekursiv
+# Ausgabe: success (boolean) / Wurde der DN verschoben, dann 1 sonst 0
+# -------------------------------------------------------------------------------------------------
+sub moveDn( $$$$$ ) {
+
+ # Eingabevariablen
+ my ( $self, $inConnection, $inSourceDn, $inNewDn, $inRecursive ) = @_;
+
+
+ # Verwendete Variablen
+ my $success;
+
+ $success = $self->copyDn( $inConnection, $inSourceDn,
+ $inNewDn, $inRecursive );
+
+ $logger->debug("moveDN(): back from copyDN");
+
+ if( $success ) {
+
+ $success = $self->deleteDn( $inConnection, $inSourceDn, $inRecursive );
+
+ }
+
+
+ # Rueckgabe
+ return $success
+
+}
+
+
+# -------------------------------------------------------------------------------------------------
+# Name: copyDn
+# Eingabe: inConnection (Handler) / Ein LDAP-Verbindungs-Handler
+# inSourceDn (string) / Eine DN, die kopiert werden soll
+# inNewDn (string) / Das Ziel, wohin kopiert werden soll
+# inRecursive (boolean) / Rekursiver Aufruf der Funktion
+# Funktion: Kopiert einen DN in einen anderen Teilbaum, bei Angabe von inRecursive auch rekursiv
+# Ausgabe: success (boolean) / Wurde der DN kopiert, dann 1 sonst 0
+# -------------------------------------------------------------------------------------------------
+sub copyDn( $$$$$ ) {
+
+ # Eingabevariablen
+ my ( $self, $inConnection, $inSourceDn, $inNewDn, $inRecursive ) = @_;
+
+
+ # Verwendete Variablen
+ my $success = 0;
+ my $copy;
+ my $search;
+ my $filter;
+ my $entry;
+ my $entryName;
+ my @tmp;
+ my $result;
+
+ # Filterregel
+ $filter = "(objectClass=*)";
+
+
+ # Den Eintrag aus dem Verzeichnis holen
+ $result = $inConnection->search( ( scope => "base",
+ base => $inSourceDn,
+ filter => $filter ) );
+
+ if ( $result->code ) {
+ &mylogLDAPerror("copyDN(): searching", $result);
+ }
+# if( !$search || ($search->code() != 0) ) {
+# $logger->logdie( "addUser(): Der Eintrag " . $inSourceDn . " existiert nicht im Verzeichnis." );
+# }
+ else {
+ $entry = $result->entry( 0 );
+ @tmp = split( /,/, $inSourceDn );
+ $entryName = $tmp[0];
+ $entry->dn( $entryName . "," . $inNewDn );
+
+
+ # Die eigentliche DN kopieren
+ $result = $inConnection->add( $entry );
+ if ( $result->code ) {
+ &mylogLDAPerror("copyDN: adding", $result);
+ return 0;
+ }
+#
+# if( !$copy ) {
+# $logger->logdie( "copyDn(): Es ist ein Fehler beim Kopieren der DN " . $inSourceDn . " aufgetreten." );
+#
+# }
+ else {
+ $logger->info( "copyDn(): " . $inSourceDn . " wurde nach ".
+ $entry->dn(). " kopiert." );
+ $success = 1;
+ }
+
+ $logger->debug("are we recursive: $inRecursive");
+
+ # Bei Rekursion zuerst alle Unterknoten loeschen!
+ if( $inRecursive ) {
+ # Filterregel
+ $filter = "(objectClass=*)";
+
+ # Suche ans LDAP-Verzeichnis senden
+ $result = $inConnection->search( ( scope => "one",
+ base => $inSourceDn,
+ filter => $filter ) );
+
+ if ( $result->code ) {
+ &mylogLDAPerror("copyDN() rekursive: searching", $result);
+ }
+# if( !$search ||($search->code() != 0) ) {
+#
+# $logger->logdie( "copyDn(): Bei der Suche unterhalb der DN " . $inSourceDn . " ist ein Fehler aufgetreten." );
+#
+# }
+ else {
+ $success = 1;
+ foreach $entry ( $result->entries ) {
+
+ $success = $success && $self->copyDn( $inConnection,
+ $entry->dn(),
+ $entryName . "," .
+ $inNewDn,
+ $inRecursive );
+ }
+ }
+ }
+ }
+ # Rueckgabe
+ return $success;
+}
+
+
+# -------------------------------------------------------------------------------------------------
+# Name: deleteDn
+# Eingabe: inConnection (Handler) / Ein LDAP-Verbindungs-Handler
+# inDn (string) / Ein DN
+# inRecursive (boolean) / Rekursiver Aufruf der Funktion
+# Funktion: Loescht einen DN, bei Angabe von inRecursive auch rekursiv
+# Ausgabe: success (boolean) / Wurde der DN geloescht, dann 1 sonst 0
+# -------------------------------------------------------------------------------------------------
+sub deleteDn( $$$$ ) {
+
+ # Eingabevariablen
+ my ( $self, $inConnection, $inDn, $inRecursive ) = @_;
+
+
+ # Verwendete Variablen
+ my $success = 0;
+ my $delete;
+ my $search;
+ my $filter;
+ my $entry;
+ my $result;
+
+ $logger->debug("In LDAP::deleteDN");
+
+ # Bei Rekursion zuerst alle Unterknoten loeschen!
+ if( $inRecursive ) {
+ $logger->debug("deleteDN() we are in recursivemode here");
+ # Filterregel
+ $filter = "(objectClass=*)";
+
+
+ # Suche ans LDAP-Verzeichnis senden
+ $result = $inConnection->search( ( scope => "one",
+ base => $inDn,
+ filter => $filter ) );
+ if ( $result->code ) {
+ &mylogLDAPerror("deleteDN(): searching", $result);
+ }
+# if( $search->code() != 0 ) {
+#
+# $logger->logdie( "deleteDn(): Bei der Suche unterhalb der DN " . $inDn . " ist ein Fehler aufgetreten." );
+#
+# }
+ else {
+ foreach $entry ( $result->entries ) {
+ $self->deleteDn( $inConnection, $entry->dn(), $inRecursive );
+ }
+ }
+ }
+
+
+ # Die eigentliche DN loeschen
+ $result = $inConnection->delete( $inDn );
+
+ # Fehlerbehandlung
+ if ( $result->code ) {
+ &mylogLDAPerror("deleteDN(): deleting", $result);
+ }
+# if( !$delete || ($delete->code() != 0) ) {
+#
+# $logger->logdie( "deleteDn(): Bei der Loeschung der DN " . $inDn . " ist ein Fehler aufgetreten." );
+#
+# }
+ else {
+ $logger->info( "deleteDn(): DN " . $inDn . " wurde entfernt." );
+ $success = 1;
+ }
+
+
+ # Rueckgabe
+ return $success;
+
+}
+
+sub searchValueFromLDAP {
+ my $self = shift;
+ my ( $attr, $mapvalue, $mapattr, $uri, $searchtype, $pwtoken, $ldap,
+ $rh_ldapserver, $is_multi ) = @_;
+
+# print "*** attr: $attr, is_multi: $is_multi\n";
+ my $cmp = '';
+
+ if ( ! $ldap ) {
+ ## we must create Session (and end it when finished)
+ ## using $uri and $pwtoken
+ }
+
+
+ my $attrval ='';
+
+ if ( ! $self->{entries_found}{$mapvalue} ) {
+
+ ## we could evaluate searchtype here for using substring match etc.
+ my $filter = "($mapattr = $mapvalue)";
+ $rh_ldapserver->{filter} = $filter;
+
+ my $mesg = $self->doSearch($ldap, $rh_ldapserver);
+
+ my $entry = undef;
+ if ($mesg->code == Net::LDAP::LDAP_SUCCESS && $mesg->entries == 1) {
+
+ $logger->debug("found exactly one entry");
+ $entry = $mesg->pop_entry();
+ if ( ! $is_multi ) {
+ $attrval = $entry->get_value( $attr );
+# print "NONMULTI: $attrval\n";
+ }
+ else {
+ my @attrvals = $entry->get_value( $attr );
+ $attrval = join(' $ ', @attrvals);
+# print "MULTIVALUES: @attrvals\n";
+ }
+ $self->{entries_found}{$mapvalue} = $entry;
+ } else {
+ $logger->warn("Entry with search $filter not found");
+ }
+ }
+ else {
+ $logger->debug("found entry already stored in Object");
+ if ( ! $is_multi ) {
+ $attrval = $self->{entries_found}{$mapvalue}->get_value( $attr );
+ }
+ else {
+ my @attrvals =
+ $self->{entries_found}{$mapvalue}->get_value( $attr );
+ $attrval = join(' $ ', @attrvals);
+ }
+ }
+
+ if ( $attrval ) {
+ $logger->debug("found $attr value $attrval");
+ }
+ else {
+ $logger->warn("found no value in attr $attr");
+ }
+
+
+
+ return ( $attrval);
+
+}
+
+sub getParentDn_better {
+
+ my $self = shift;
+ my ($dn) = @_;
+
+
+ my $ra_dns = ldap_explode_dn( $dn );
+
+
+ shift @{$ra_dns};
+# pop @{$ra_dns};
+ my $parentdn='';
+ foreach my $dnpart ( @{$ra_dns} ) {
+ my $key = keys %{$dnpart};
+ my $val = values %{$dnpart};
+
+ $parentdn .= "$key=$val,";
+ }
+
+ $parentdn =~ s/,$//;
+ $logger->info("parent dn: $parentdn");
+
+ return $parentdn;
+}
+
+sub getParentDn {
+ my $self = shift;
+ my ( $dn ) = @_;
+ $logger->debug("getting parent dn of $dn");
+### Todo us explodeDN to make this safe!!!
+ $dn =~ s/^.+?,//;
+ $logger->info("got parent dn $dn");
+
+ return($dn);
+
+}
+
+sub insertFilterInUri {
+ my $self = shift;
+ my ( $uri, $filter ) = @_;
+
+ $uri =~ s/^([^?]*\?\?\?)/$1$filter/;
+
+ return $uri;
+}
+
+sub mylogLDAPerror
+ {
+ my ($from, $mesg) = @_;
+ $logger->error("Error while $from: Return code: ", $mesg->code);
+ $logger->error("\tMessage: ". $mesg->error_name . " :". $mesg->error_text
+ . "MessageID: ". $mesg->mesg_id . "\tDN: ". $mesg->dn);
+ }
+
+
+sub createldaptimefilter {
+ my $self = shift;
+ my ( $mode,$attr, $timestring ) = @_;
+ my $filter='';
+ my $operator ='';
+
+# my ($sec,$min,$hours,$mday,$mon,$year) = localtime();
+ my $now = time();
+
+# print "XXXXXX mode: |$mode| attr: |$attr| timestr: |$timestring|\n";
+
+ if ( $mode eq "OLDER_THAN" ) {
+ $operator = '<=';
+ }
+ else {
+ print "### unsupported mode |$mode| in createldaptimefilter\n";
+ $logger->error("unsupported mode |$mode| in createldaptimefilter");
+ return '';
+ }
+
+ my ($number,$type) = ($timestring =~ /(\d+)([YMDhms])/);
+
+ my $seconds;
+
+ if ( $type ) {
+# print "number: |$number| type: |$type|\n";
+
+ if ( $type eq 's' ) {
+ $seconds = $number;
+ }
+ elsif ( $type eq 'm' ) {
+ $seconds = $number * 60;
+ }
+ elsif ( $type eq 'h' ) {
+ $seconds = $number * 60 * 60;
+ }
+ elsif ( $type eq 'D' ) {
+ $seconds = $number * 60 * 60 * 24;
+ }
+ elsif ( $type eq 'M' ) {
+ $seconds = $number * 60 * 60 * 24 * 30;
+ }
+ elsif ( $type eq 'Y' ) {
+ $seconds = $number * 60 * 60 * 24 * 365;
+ }
+ }
+ else {
+ print "### Wrong syntax in time abreviation allowed are only a number followed by 's' 'm' 'h' 'D' 'M' or 'Y'\n";
+ $logger->error("Wrong syntax in time abreviation");
+ return '';
+ }
+
+ my $past = $now - $seconds;
+
+ my ($nsec,$nmin,$nhours,$nmday,$nmon,$nyear) = localtime();
+
+ my ($sec,$min,$hours,$mday,$mon,$year) = localtime($past);
+ my $ntime = sprintf("%04d%02d%02d%02d%02d%02dZ",
+ ($nyear+1900),($nmon+1),
+ $nmday,$nhours,$nmin,$nsec);
+ my $time = sprintf("%04d%02d%02d%02d%02d%02dZ",
+ ($year+1900),($mon+1),
+ $mday,$hours,$min,$sec);
+
+# print "now is : $ntime\n";
+# print "searching: $time\n";
+
+ $filter = "($attr$operator$time)";
+
+ return $filter;
+}
+
+sub regexp2ldapfilter {
+ my $self = shift;
+ my ( $regexp, $attr ) = @_;
+ my $filter='';
+
+# if ( $regexp =~ m|^s/(.+)/.*| ) {
+# $regexp = $1;
+# }
+
+
+ my $ismulti=0;
+ if ( $regexp =~ /\#;/ || $attr =~ /;/ ) {
+ $ismulti = 1;
+ }
+
+ foreach my $attrib ( split /;/, $attr ) {
+ foreach my $re ( split /\#;/, $regexp ) {
+
+ $re =~ s|(\^?[^\.\*\+\?\(]+).*|$1|;
+ $re =~ s|\\x|\\|g;
+ $re = $self->quoteldapfilter($re);
+ my $part = "*$re*";
+ $part =~ s/^\*\^//;
+ $filter .= "( $attrib=$part) ";
+ }
+
+ }
+
+ if ( $ismulti) {
+ $filter = '(| '.$filter.')';
+ }
+ return $filter;
+
+}
+
+sub quoteldapfilter {
+ my $self = shift;
+ my ( $string ) = @_;
+
+ $string =~ s/ /\\20/g;
+ $string =~ s/>/\\3e/g;
+ $string =~ s/</\\3c/g;
+
+ return $string;
+}
+
+1;
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/LOG.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/LOG.pm
new file mode 100644
index 0000000000000000000000000000000000000000..2336a2b0d4bf7b7f91ebbc6918e0485ba744640d
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/LOG.pm
@@ -0,0 +1,162 @@
+package DAASIlib::LOG;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+use Log::Log4perl qw(:levels);
+#use Log::Log4perl::Level;
+
+
+
+
+our $logger = Log::Log4perl->get_logger("main");
+
+our $VERSION = "0.1";
+our $ISDEBUG=0;
+
+our $OFF;
+
+sub new
+{
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ };
+
+ bless($self , $class );
+
+ return $self;
+}
+
+
+sub init {
+ my $self = shift;
+ my ( $progname, $is_verbose ) = @_;
+
+ $self->{data}{progname} = $progname;
+ $self->{data}{is_verbose} = $is_verbose;
+
+}
+
+sub logStartmessage {
+ my $self = shift;
+
+ my $progname = $self->{data}{progname};
+ $logger->error("**** $progname started ****");
+
+ print "\n$progname started\n" if $self->{data}{is_verbose};
+}
+
+sub logAndExit {
+ my $self = shift;
+
+ my $progname = $self->{data}{progname};
+ $logger->error("**** $progname ended ****");
+
+ print "$progname ended\n" if $self->{data}{is_verbose};
+ exit();
+}
+
+
+sub initLog4Perl {
+ my $self = shift;
+ my ( $logfile, $loglevel, $is_debug ) = @_;
+
+ use Log::Log4perl qw(:levels);
+ use Log::Log4perl::Level;
+ use Log::Log4perl::Appender::Screen;
+ use Log::Log4perl::Appender;
+# use Log::Log4perl::Filter::LevelMatch;
+# use Log::Log4perl::Filter;
+
+## We want an additional Loglevel for log messages containing privacy relevant
+## data:
+# Log::Log4perl::Logger::create_custom_level("PRIVATE", "WARN");
+
+
+ my $log = Log::Log4perl->get_logger('');
+
+ my $layout = Log::Log4perl::Layout::PatternLayout->new("%d> %p: %m (%F %L)%n");
+
+ my $filename = $logfile;
+ if ( $filename =~ m|^([\w./-]+)$| ) {
+ $filename = $1;
+ }
+ else {
+ die "\n####### Filename $filename contains invalid characters\n";
+ }
+
+
+
+ # Filter to match level Private
+# log4perl.filter.MatchPrivate = Log::Log4perl::Filter::LevelMatch
+# log4perl.filter.MatchPrivate.LevelToMatch = PRIVATE
+# log4perl.filter.MatchPrivate.AcceptOnMatch = true
+# my $privateFilter =
+# Log::Log4perl::Filter::LevelMatch->new("Log::Log4perl::Filter",
+# LevelToMatch => 'ERROR',
+# LaccepTonMatch => 'true');
+
+ # Filter to match all error and warnings level
+# log4perl.filter.MatchAllErrors = Log::Log4perl::Filter::LevelRange
+# log4perl.filter.MatchAllErrors.LevelMin = WARN
+# log4perl.filter.MatchAllErrors.LevelMax = FATAL
+# log4perl.filter.MatchAllErrors.AcceptOnMatch = true
+
+ # Filter to match all non private non errors
+# log4perl.filter.MatchAllAccess = Log::Log4perl::Filter::LevelRange
+# log4perl.filter.MatchAllAccess.LevelMin = DEBUG
+# log4perl.filter.MatchAllAccess.LevelMax = INFO
+# log4perl.filter.MatchAllAccess.AcceptOnMatch = true
+
+# my $file_app_error =
+# Log::Log4perl::Appender->new("Log::Log4perl::Appender::File",
+# name => "filelog",
+# filename => "$filename.error",
+# layout => $layout,
+# filter => "MatchAllErrors");
+# my $file_app_access =
+# Log::Log4perl::Appender->new("Log::Log4perl::Appender::File",
+# name => "filelog",
+# filename => "$filename.access",
+# layout => $layout,
+# filter => "MatchAllAccess");
+ my $file_app =
+ Log::Log4perl::Appender->new("Log::Log4perl::Appender::File",
+ name => "filelog",
+ filename => $filename);
+
+
+ $file_app->layout($layout);
+ $log->add_appender($file_app);
+
+
+# $log->add_appender($file_app_error);
+# $log->add_appender($file_app_access);
+
+ if ( $is_debug ) {
+ my $screenlayout = Log::Log4perl::Layout::PatternLayout->new(" %m %n%n");
+ my $stdout_app =
+ Log::Log4perl::Appender->new("Log::Log4perl::Appender::Screen",
+ name => "screenlog",
+ stderr => 0);
+ $stdout_app->layout($screenlayout);
+ $log->add_appender($stdout_app);
+ }
+
+
+ $log->level($loglevel);
+
+ return ($log);
+}
+
+
+
+
+1;
diff --git a/info.textgrid.middleware.tgauth.passwordReset/lib/SMTP.pm b/info.textgrid.middleware.tgauth.passwordReset/lib/SMTP.pm
new file mode 100644
index 0000000000000000000000000000000000000000..0cf27e32850782b6d9c7da6403bbf6d5929f5421
--- /dev/null
+++ b/info.textgrid.middleware.tgauth.passwordReset/lib/SMTP.pm
@@ -0,0 +1,287 @@
+#!/usr/bin/perl -w
+
+
+package DAASIlib::SMTP;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+our $VERSION = "0.1";
+
+use Log::Log4perl qw(:levels);
+my $logger = Log::Log4perl->get_logger('');
+use DAASIlib::Data;
+my $data = new DAASIlib::Data;
+
+
+my $enhancedheader = "User-Agent: Net::SMTP\nMIME-Version: 1.0\nContent-Type: text/plain; charset=utf-8\nContent-Transfer-Encoding: 8bit\n";
+
+my $defaultagent = "Net::SMTP";
+my $defaultcontenttype = "text/plain";
+my $boundary = "frontier";
+my $defaultmulticontenttype = "multipart/mixed; boundary=\"$boundary\"";
+my $defaulthtmlmulticontenttype = "multipart/alternative; boundary=\"$boundary\"";
+my $defaultcharset = "utf-8";
+my $defaultencoding = "8bit";
+
+my $enhancedmailxheader = ' -a "User-Agent: Net::SMTP" -a "MIME-Version: 1.0" -a "Content-Type: text/plain; charset=utf-8" -a "Content-Transfer-Encoding: 8bit"';
+
+use Net::SMTP;
+
+sub new {
+ my $class;
+ my $self;
+
+ my ( $this , $param ) = @_;
+ $class = ref($this) || $this;
+
+ $self={
+ data => {},
+ };
+
+ bless($self , $class );
+
+ return $self;
+
+}
+
+sub set_server {
+ my $self = shift;
+ my ($server, $charset, $encoding, $agent, $hello ) = @_;
+
+ $self->{data}{smtprelay} = $server;
+ if ( $server eq 'LOCAL' | $server eq 'SYSTEM' ) {
+ $self->{data}{norelay} = 1;
+ }
+
+ if ( $hello ) {
+ $self->{data}{hello} = $hello;
+ }
+
+ if ( $charset ) {
+ $self->{data}{charset} = $charset;
+ }
+ else {
+ $self->{data}{charset} = $defaultcharset;
+ }
+
+ if ( $encoding ) {
+ $self->{data}{encoding} = $encoding;
+ }
+ else {
+ $self->{data}{encoding} = $defaultencoding;
+ }
+
+ if ( $agent ) {
+ $self->{data}{agent} = $agent;
+ }
+ else {
+ $self->{data}{agent} = $defaultagent;
+ }
+
+}
+
+sub send_mail {
+ my $self = shift;
+ my ($from, $subject, $mail_data,
+ $to_mail_addresses, $cc_mail_addresses,
+ $bcc_mail_addresses, $authname, $ishtml, $attachments ) = @_;
+ my $smtp;
+
+ if ( ! $self->{data}{smtprelay} ) {
+ $logger->error("send_mail() called without a server set");
+ $logger->error("you have to first call set_server, before you can use method send_mail");
+ print "you have to first call set_server, before you can use method send_mail\n";
+ exit();
+ }
+
+ my $contenttype;
+
+ if ( $attachments ) {
+ $contenttype = $defaultmulticontenttype;
+ }
+ elsif ( $ishtml ) {
+ $contenttype = $defaulthtmlmulticontenttype;
+ }
+ else {
+ $contenttype = $defaultcontenttype;
+ }
+
+# my $hello = $data->getip();
+# my $hello = 'usha.daasi.int';
+
+ my $header;
+ my $timestamp = $self->create_timestamp();
+
+
+ if ( $self->{data}{norelay} ) {
+ $header = ' -a "From: '.$from.'"';
+ $header .= ' -a "Date: '.$timestamp.'"';
+ $header .= $enhancedmailxheader;
+
+ my $adds = '';
+ if ( $cc_mail_addresses ) {
+ $adds .= ' -c '.$cc_mail_addresses;
+ }
+ if ( $bcc_mail_addresses ) {
+ $adds .= ' -b '.$bcc_mail_addresses;
+ }
+ $mail_data = "\"$mail_data\"";
+
+ my $command = "echo $mail_data | mailx -s \"$subject\" $adds $header $to_mail_addresses";
+ $logger->error("sending the following to system: \n$command\n");
+ system ($command);
+ }
+ else {
+
+ $header = "From: $from\nTo: $to_mail_addresses\n";
+ $smtp = Net::SMTP->new($self->{data}{smtprelay},
+ Hello => $self->{data}{hello},
+ );
+
+ if (! $smtp) {
+ $logger->error("first try to connect to relay failed");
+ $logger->error("will try again in 10 seconds");
+ sleep 10;
+ $smtp = Net::SMTP->new($self->{data}{smtprelay});
+ if (! $smtp) {
+ $logger->error("second try to connect to relay failed");
+ $logger->error("will abort sending mail");
+ print "##### ERROR couldn't open new connection to smtp server!!\n";
+ return 0;
+ }
+ }
+
+ my $authpw='';
+ if ( $authname ) {
+ $authpw = $data->getSecret('smtpauth');
+ $smtp->auth($authname,$authpw);
+ $logger->debug("performed SMTP AUTH with user $authname");
+ }
+
+ $smtp->mail($from);
+ $smtp->to ( split ( /,/, $to_mail_addresses ));
+
+# $smtp->to ( split ( /,/, $to_mail_addresses ), { Notify => ['FAILURE','DELAY'], SkipBad => 1 });
+# könnte man noch hinten dran stellen noch nicht getestet!
+
+ if ( $cc_mail_addresses ) {
+ $smtp->cc ( split ( /,/, $cc_mail_addresses ));
+ $header .= "Cc: $cc_mail_addresses\n";
+ }
+
+ if ( $bcc_mail_addresses ) {
+ $smtp->bcc ( split ( /,/, $bcc_mail_addresses ));
+ }
+
+ my $timestamp = $self->create_timestamp();
+
+ $header .= "Date: $timestamp\n";
+ $header .= "Subject:$subject\n";
+ $header .= "User-Agent: ".$self->{data}{agent}."\n";
+
+ $header .= "MIME-Version: 1.0\n";
+
+
+ $header .= "Content-Type: $contenttype";
+ if ( ! $ishtml && ! $attachments ) {
+ $header .= "; charset=".$self->{data}{charset}."\n";
+ $header .= "Content-Transfer-Encoding: ".$self->{data}{encoding}."\n\n";
+ $smtp->data($header,
+ $mail_data);
+ }
+ else {
+ $header .= "\n\n";
+ $header .= "This is a message with multiple parts in MIME format.\n";
+ my $htmlmail_data='';
+ if ( $ishtml ) {
+ $htmlmail_data = $self->create_html_mail($mail_data);
+ $smtp->data();
+ $smtp->datasend($header);
+ $smtp->datasend("--$boundary\n");
+ $smtp->datasend("Content-type: $defaultcontenttype; charset="
+ .$self->{data}{charset}."\n");
+# $smtp->datasend("Content-Disposition: quoted-printable\n");
+ $smtp->datasend("Content-Transfer-Encoding: "
+ .$self->{data}{encoding}."\n\n");
+ $smtp->datasend($mail_data);
+ $smtp->datasend("--$boundary\n");
+ $smtp->datasend("Content-type: text/html; charset="
+ .$self->{data}{charset}."\n");
+ $smtp->datasend("Content-Transfer-Encoding: "
+ .$self->{data}{encoding}."\n\n");
+ $smtp->datasend($htmlmail_data);
+ $smtp->datasend("\n--$boundary--\n");
+ $smtp->dataend();
+ }
+ else {
+ ### TODO handle attachements here
+ }
+ }
+
+ $smtp->quit;
+ }
+ return 1;
+
+} # send_mail
+
+sub create_html_mail {
+ my $self = shift;
+ my ( $data ) = @_;
+
+ my $header = '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">'
+ ."\n"
+ .'<html><head><meta http-equiv="Content-Type" content="text/html; charset="'
+ .$self->{data}{charset}. '" />'
+ ."\n</head>\n\n<body>";
+
+# print "|$header|\n";
+
+ $data =~ s|([ \n])\*(.*?)\*([ \n.,])|$1<b>$2</b>$3|g;
+
+ if ( $data =~ m{http://} ) {
+ $data =~ s{(http://.*?)([ )\n]|[\.,;:] )}{<a href="$1">$1</a>$2}g;
+ $data =~ s{(https://.*?)([ )\n]|[\.,;:] )}{<a href="$1">$1</a>$2}g;
+
+ }
+ else {
+ $data =~ s{([^/])(www\..*?)([ )\n]|[\.,;:] )}{$1<a href="http://$2">$2</a>$3}g;
+ $data =~ s{(https://.*?)([ )\n]|[\.,;:] )}{<a href="$1">$1</a>$2}g;
+ }
+ $data =~ s{([\w\-\.]*?\@[\w\-\.]*?)([ )\n]|[\.,;:] )}{<a href="mailto:$1">$1</a>$2}g;
+ $data =~ s|\n|<br>\n|g;
+
+ $data = "$header$data</html>";
+
+ return ( $data);
+}
+
+
+
+sub create_timestamp {
+ my $self = shift;
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
+
+ my $utcdiff = 2;
+
+ if ( $isdst ) {
+ $utcdiff++;
+ }
+
+ my @monabbr = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+ my $monstr = $monabbr[$mon];
+
+ my @wdayabbr = qw( Sun Mon Tue Wed Thu Fri Sat );
+ my $wdaystr = $wdayabbr[$wday];
+
+ $year+=1900;
+# my $datestring = sprintf("${wdaystr}, $mday $monstr $year ${hour}:${min}:${sec} +0${utcdiff}00";
+ my $datestring = sprintf("%s, %02d %s %04d %02d:%02d:%02d +%02d00",
+ $wdaystr,$mday,$monstr,$year,
+ $hour,$min,$sec,$utcdiff);
+ return $datestring;
+
+}
+
+1;