2021-12-30 12:05:56 +01:00
package Shareework ;
#
# SPDX-License-Identifier: AGPL-3.0-or-later
# Copyright (c) Rainer Gümpelein, TeilRad GmbH
#
#disable for syntax check
#use lib qw(/var/www/copri4/shareeapp-primary/src);
use strict ;
use warnings ;
use POSIX ;
use CGI ; # only for debugging
use Mod::Libenzdb ;
use Mod::Libenz ;
use Mod::DBtank ;
use Mod::Buttons ;
use Lib::Config ;
use Mod::APIfunc ;
use Digest::MD5 qw( md5 md5_hex ) ;
use Digest::SHA qw( sha1_base64 ) ;
use Scalar::Util qw( looks_like_number ) ;
2022-01-14 19:41:45 +01:00
use URI::Encode ;
2021-12-30 12:05:56 +01:00
use Mod::Prelib ;
use Mod::Basework ;
use Mod::Payment ;
#use Mod::MailTransport;
use Mod::SMSTransport ;
use Data::Dumper ;
my $ cf = new Config ;
my $ but = new Buttons ;
my $ db = new Libenzdb ;
my $ lb = new Libenz ;
my $ dbt = new DBtank ;
my $ apif = new APIfunc ;
my $ pl = new Prelib ;
my $ bw = new Basework ;
my $ payone = new Payment ;
#my $mailtrans = new MailTransport;
my $ smstrans = new SMSTransport ;
my $ q = new CGI ;
2022-01-14 19:41:45 +01:00
my $ uri_encode = URI::Encode - > new ( { encode_reserved = > 1 } ) ;
2021-12-30 12:05:56 +01:00
sub new {
my $ class = shift ;
my $ self = { } ;
bless ( $ self , $ class ) ;
return $ self ;
}
my $ i_rows = 0 ;
my $ u_rows = 0 ;
my $ d_rows = 0 ;
#
#also done in src/Tpl/Anmelden.pm!?
sub delete_account {
my $ self = shift ;
my $ c_id = shift ;
my $ owner = shift ;
my $ now_dt = strftime "%Y-%m-%d %H:%M:%S" , localtime ;
my % varenv = $ cf - > envonline ( ) ;
my $ debug = 1 ;
my $ dbh = "" ;
$ bw - > log ( "delete_account" , $ c_id , "" ) ;
open ( FILE , ">>$varenv{logdir}/delete_account.log" ) if ( $ debug ) ;
my $ dbh_primary = $ dbt - > dbconnect_extern ( "sharee_primary" ) ;
my $ authref = {
table = > "contentadr" ,
fetch = > "one" ,
template_id = > "202" ,
c_id = > "$c_id" ,
} ;
my $ ctadr = $ dbt - > fetch_record ( $ dbh_primary , $ authref ) ;
print FILE "\n*-->DB $varenv{dbname} $now_dt| owner: $owner | c_id: $c_id \n" if ( $ debug ) ;
#First on operator DMS delete and then second on primary delete txt17 operator DB
if ( $ varenv { dbname } ne "sharee_primary" ) {
$ d_rows += $ dbt - > delete_content ( $ dbh , "contentadr" , $ c_id ) ;
my $ update_primary = {
table = > "contentadr" ,
mtime = > "now()" ,
owner = > "$owner" ,
c_id = > "$c_id" ,
} ;
my @ operators = ( "$ctadr->{txt17}" ) ;
@ operators = split ( /\s+/ , $ ctadr - > { txt17 } ) if ( $ ctadr - > { txt17 } =~ /\w\s\w/ ) ;
my @ new_operators = ( ) ;
foreach ( @ operators ) {
push ( @ new_operators , $ _ ) if ( $ _ =~ /sharee_\w+/ && $ _ !~ /$varenv{dbname}/ ) ;
}
print FILE "delete operator dbname: $varenv{dbname} | update_primary txt17='@new_operators'\n" ;
$ u_rows = $ dbt - > update_one ( $ dbh_primary , $ update_primary , "txt17='@new_operators'" ) ;
$ u_rows = $ dbt - > update_one ( $ dbh_primary , $ update_primary , "txt19=null" ) ;
} else {
print FILE "delete on all by operatorsloop by primary\n" ;
$ dbt - > update_operatorsloop ( $ varenv { dbname } , $ ctadr - > { c_id } , "delete" ) ;
$ d_rows += $ dbt - > delete_content ( $ dbh , "contentadr" , $ c_id ) ;
}
close ( FILE ) if ( $ debug ) ;
return "$i_rows-$u_rows-$d_rows" ;
}
sub check_account () {
my $ self = shift ;
my ( $ column2 , $ op2 , $ content2 , $ column3 , $ op3 , $ content3 ) = @ _ ;
my $ table = "contentadr" ;
$ content2 = $ q - > escapeHTML ( "$content2" ) ;
my $ account_check = $ db - > get_like2sort ( "contentadr" , "" , "" , "$column2" , "$op2" , "$content2" , "$column3" , "$op3" , "$content3" ) ;
return $ account_check ;
}
#create_account is alwas done on primary first
sub create_account () {
my $ self = shift ;
my $ owner = shift ;
my $ table = "contentadr" ;
my $ c_idnew = $ db - > insert_content ( $ table ) ;
$ db - > updater ( "$table" , "c_id" , $ c_idnew , "ct_name" , "$c_idnew" , "$owner" ) ;
$ db - > updater ( "$table" , "c_id" , $ c_idnew , "barcode" , "$c_idnew" , "$owner" ) ;
$ db - > updater ( "$table" , "c_id" , $ c_idnew , "int20" , "$owner" , "$owner" ) ;
my $ rel_idnew = $ db - > insert_relationlist ( $ table , "200011" , "de" , $ c_idnew , "202" , "ca_id" ) ;
return $ c_idnew ;
}
#sharee save_account is always done on primary first
sub save_account () {
my $ self = shift ;
my $ c_id = shift ;
2022-01-16 12:17:11 +01:00
my $ varmerch = shift || "" ;
2021-12-30 12:05:56 +01:00
my $ owner = shift || 0 ;
my $ table = "contentadr" ;
$ q = new CGI ;
$ q - > import_names ( 'R' ) ;
my @ keywords = $ q - > param ;
my $ now_dt = strftime "%Y-%m-%d %H:%M:%S" , localtime ;
my % varenv = $ cf - > envonline ( ) ;
2022-01-16 12:17:11 +01:00
$ bw - > log ( "save_account by varmerchant_id $varmerch->{merchant_id} on dbname $varenv{dbname}" , $ q , "" ) ;
2021-12-30 12:05:56 +01:00
my $ debug = 1 ;
my $ dbh = "" ; #keep in mind, empty dbh defaults to local copri-instance dbname
open ( FILE , ">>$varenv{logdir}/save_account.log" ) if ( $ debug ) ;
#Always on sharee_primary
if ( $ varenv { dbname } ne "sharee_primary" ) {
$ dbh = $ dbt - > dbconnect_extern ( "sharee_primary" ) ;
2022-01-16 12:17:11 +01:00
print FILE "\n*-->If no-primary connect DB sharee_primary (mvar: $varmerch->{merchant_id}|$varmerch->{dbname}|$varenv{dbname}) $now_dt| c_id: $c_id| owner: $owner\n" if ( $ debug ) ;
2021-12-30 12:05:56 +01:00
} else {
#keep in mind, should be only done by web-app user Formular (primary)
2022-01-16 12:17:11 +01:00
print FILE "\n*-->Else take local copri-Instance DB $varenv{dbname} (mvar: $varmerch->{merchant_id}|$varmerch->{dbname}) $now_dt| c_id: $c_id| owner: $owner\n" if ( $ debug ) ;
2021-12-30 12:05:56 +01:00
}
my $ authref = {
table = > "contentadr" ,
fetch = > "one" ,
template_id = > "202" ,
c_id = > "$c_id" ,
} ;
my $ ctadr = $ dbt - > fetch_record ( $ dbh , $ authref ) ;
my $ update_primary = {
table = > "contentadr" ,
mtime = > "now()" ,
owner = > "$owner" ,
c_id = > "$c_id" ,
} ;
my $ ret = "" ;
my $ ret_conflict = "" ;
my $ fkeys = "" ;
my $ pw_dummy = "" ;
@ keywords = grep { ! /txt31/ } @ keywords ;
print FILE Dumper ( $ q ) if ( $ debug ) ;
foreach ( @ keywords ) {
$ fkeys . = "$_," ;
my $ val = $ q - > param ( "$_" ) ;
my $ valxx = $ q - > escapeHTML ( "$val" ) ;
$ valxx =~ s/^\s+// ;
$ valxx =~ s/\s+$// ;
print FILE "$_:$valxx \n" if ( $ debug ) ;
if ( $ _ =~ /^int|barcode/ ) {
$ valxx =~ s/,/./g ;
if ( looks_like_number ( $ valxx ) ) {
$ valxx = $ valxx ;
} else {
$ valxx = "null"
}
}
if ( $ _ =~ /^txt[\d+]|^int[\d+]|^uri[\d+]|ct_name/ ) {
#PW
if ( $ _ =~ /^txt04/ ) {
if ( $ valxx eq "xxxxxxxx" ) {
$ pw_dummy = "1" ;
} elsif ( $ valxx ) {
my $ pwmd5 = md5_hex ( $ valxx ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt11='$pwmd5'" ) ;
}
}
#operators, only if saved by operator DMS
elsif ( $ _ eq "txt17" ) {
my % txt17 = ( ) ;
if ( $ ctadr - > { txt17 } =~ /\w\s\w/ ) {
% txt17 = map { $ _ = > 1 } split ( /\s+/ , $ ctadr - > { txt17 } ) ;
} else {
$ txt17 { $ ctadr - > { txt17 } } = 1 ;
}
my $ txt19 = $ q - > escapeHTML ( $ q - > param ( 'txt19' ) ) || "" ;
if ( $ txt19 && $ dbt - > { operator } { $ txt19 } - > { database } - > { dbname } ) {
$ txt17 { $ dbt - > { operator } { $ txt19 } - > { database } - > { dbname } } = 1 ;
}
my @ operators = ( ) ;
foreach my $ keys ( keys % txt17 ) {
push ( @ operators , $ keys ) ;
}
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt17='@operators'" ) ;
}
#Web-Login|Rabatt|Vde|payone cron-intervall|Ilockit-Admin
2022-02-22 08:31:35 +01:00
#elsif($_ =~ /int05|int07|int16|int19/){
2021-12-30 12:05:56 +01:00
elsif ( $ _ =~ /int05|int07|int16|int19/ ) {
$ u_rows = $ dbt - > update_one ( "" , $ update_primary , "$_=$valxx" ) ;
}
#user_tour
elsif ( $ _ =~ /txt18/ ) {
my @ txt18 = $ q - > param ( 'txt18' ) ;
@ txt18 = grep { ! /null/ } @ txt18 ;
$ u_rows = $ dbt - > update_one ( "" , $ update_primary , "$_='@txt18'" ) ;
}
#Text Sonstiges
elsif ( $ _ =~ /txt29/ ) {
$ u_rows = $ dbt - > update_one ( "" , $ update_primary , "$_='$valxx'" ) ;
}
#txt15=Bonus- oder Antragsnummer (falls vorhanden)=15
#only check bonusnr and add operators dbname.
#bonustarif will be set after operator insert
elsif ( $ _ eq "txt15" ) {
#only done by App web iframe Anmelde-Registration formular
print FILE "Bonusnr request $_: $valxx\n" if ( $ debug ) ;
if ( $ varenv { dbname } eq "sharee_primary" ) {
my % txt17 = ( ) ;
if ( $ ctadr - > { txt17 } =~ /\w\s\w/ ) {
% txt17 = map { $ _ = > 1 } split ( /\s+/ , $ ctadr - > { txt17 } ) ;
} else {
$ txt17 { $ ctadr - > { txt17 } } = 1 ;
}
2022-01-16 12:17:11 +01:00
#accept SWK codes without prefix
if ( $ valxx && $ owner && ( $ owner == 195 || $ owner == 185 || $ owner == 176 || $ varenv { dbname } eq "sharee_kn" ) ) {
my $ valappend = $ valxx ;
$ valxx = "KN-$valappend" ;
print FILE "Prepare SWK Bonusnr by prefix $valxx" . "\n" if ( $ debug ) ;
}
2022-06-02 10:34:03 +02:00
#Freischaltcode format can be "CA-Li-hsze789k" or "CA1234567"
if ( $ valxx && ( $ valxx =~ /^(\w{2,3})-([\w\-]+)/i || $ valxx =~ /^(\w{2,3})(\d+)/ ) ) {
2021-12-30 12:05:56 +01:00
$ valxx =~ s/\s//g ;
my $ bonus_prefix = uc ( $ 1 ) ,
my $ bonusnr = $ 2 ;
my $ operator_conf = $ dbt - > get_operator_conf ( $ bonus_prefix ) ;
2022-01-16 12:17:11 +01:00
my @ txt30_op = ( ) ;
2021-12-30 12:05:56 +01:00
if ( ref ( $ operator_conf ) eq "HASH" && $ operator_conf - > { oprefix } && $ operator_conf - > { database } - > { dbname } ) {
2022-05-19 06:35:50 +02:00
print FILE "Bonus- oder Freischaltcode $valxx : " . $ operator_conf - > { oprefix } . " " . $ operator_conf - > { database } - > { dbname } . "\n" if ( $ debug ) ;
2021-12-30 12:05:56 +01:00
my $ dbh_operator = $ dbt - > dbconnect_extern ( $ operator_conf - > { database } - > { dbname } ) ;
#to get operator bonusnr
my $ pref_bo = {
table = > "content" ,
fetch = > "one" ,
template_id = > "228" ,
int03 = > ">::0" ,
ct_name = > "$bonusnr" ,
} ;
my $ bonus_record = $ dbt - > fetch_record ( $ dbh_operator , $ pref_bo ) ;
2022-01-16 12:17:11 +01:00
my $ bonus_collect = { } ; #will be hash on matchin SWK bonus
#also if SWK file matches
2022-01-14 19:41:45 +01:00
if ( ! $ bonus_record - > { c_id } && $ operator_conf - > { database } - > { dbname } eq "sharee_kn" ) {
2022-01-16 12:17:11 +01:00
$ bonus_record - > { ct_name } = $ lb - > grep_filecontent ( "$dbt->{copri_conf}->{basedir}/$operator_conf->{dir_app}/ftp/SWK_codes/got_last.csv" , "$bonusnr" ) ;
if ( $ bonus_record - > { ct_name } ) {
$ bonus_record - > { c_id } = 1 ;
$ bonus_record - > { int21 } = 3429 ; #Stadtrad source Tarif
$ bonus_record - > { int22 } = 3430 ; #Stadtrad target Tarif
$ bonus_collect - > { 1 } - > { ct_name } = $ bonus_record - > { ct_name } ;
$ bonus_collect - > { 1 } - > { int21 } = 3429 ;
$ bonus_collect - > { 1 } - > { int22 } = 3430 ;
$ bonus_collect - > { 2 } - > { ct_name } = $ bonus_record - > { ct_name } ;
$ bonus_collect - > { 2 } - > { int21 } = 3428 ;
$ bonus_collect - > { 2 } - > { int22 } = 3432 ;
@ txt30_op = ( "$bonus_collect->{1}->{int22}" , "$bonus_collect->{2}->{int22}" ) ;
}
print FILE "SWK bonus_collect:\n" . Dumper ( $ bonus_collect ) . "\n" ;
2022-01-14 19:41:45 +01:00
}
2021-12-30 12:05:56 +01:00
#add operators dbname only if Bonusnr matches
2022-01-16 12:17:11 +01:00
print FILE "txt15=$bonusnr requested on web Bonustarif on: $operator_conf->{database}->{dbname} --> Bonusnt:$bonus_record->{ct_name} --> int21:$bonus_record->{int21} --> int22:$bonus_record->{int22}\n" if ( $ debug ) ;
2021-12-30 12:05:56 +01:00
if ( $ bonus_record - > { c_id } ) {
$ txt17 { $ operator_conf - > { database } - > { dbname } } = 1 ;
my @ operators = ( ) ;
foreach my $ keys ( keys % txt17 ) {
push ( @ operators , $ keys ) if ( $ keys =~ /sharee_/ ) ;
}
print FILE "txt17 saving operators on primary: @operators\n" if ( $ debug ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt17='@operators'" ) ;
2022-01-16 12:17:11 +01:00
#collect operator addr with existing tariff setting
2021-12-30 12:05:56 +01:00
my $ ctadr_operator = $ dbt - > fetch_record ( $ dbh_operator , $ authref ) ;
@ txt30_op = ( "$ctadr_operator->{txt30}" ) if ( $ ctadr_operator - > { txt30 } ) ;
@ txt30_op = split ( /\s+/ , $ ctadr_operator - > { txt30 } ) if ( $ ctadr_operator - > { txt30 } =~ /\w\s+\w/ ) ;
2022-01-16 12:17:11 +01:00
#operator request by Bonusnr.
#insert adr to operator if it doesn't exist before set operator bonustarif
2021-12-30 12:05:56 +01:00
if ( ! $ ctadr_operator - > { c_id } ) {
print FILE "Bonus oprefix address INSERT adr from record_primary to operator $operator_conf->{database}->{dbname} , c_id:$ctadr->{c_id}\n" ;
my $ insert_op = {
%$ ctadr ,
table = > "contentadr" ,
mtime = > 'now()' ,
owner = > "198" ,
} ;
my $ c_id_op = $ dbt - > insert_contentoid ( $ dbh_operator , $ insert_op , "reset_adropkeys" ) ;
2022-01-16 12:17:11 +01:00
if ( $ bonus_record - > { c_id } > 3 ) { #means if not file greped with static c_id <= 3
$ dbt - > update_content4comp ( $ dbh_operator , $ bonus_record - > { c_id } , "-" , "1" ) ;
}
2022-01-23 19:16:23 +01:00
if ( $ bonus_collect - > { 1 } - > { int22 } && $ bonus_collect - > { 2 } - > { int22 } ) {
@ txt30_op = ( "$bonus_collect->{1}->{int22}" , "$bonus_collect->{2}->{int22}" ) ;
print FILE "SWK bonus_collect on adr insert:\n" . Dumper ( $ bonus_collect ) . "\n" ;
} elsif ( $ bonus_record - > { int22 } ) {
@ txt30_op = ( "$bonus_record->{int22}" ) ;
}
2021-12-30 12:05:56 +01:00
}
2022-01-16 12:17:11 +01:00
#address hash wit bonusnr
2021-12-30 12:05:56 +01:00
my $ adr_bonus = {
table = > "contentadr" ,
mtime = > "now()" ,
c_id = > $ c_id ,
txt15 = > $ bonusnr ,
txt30_array = > \ @ txt30_op ,
owner = > $ owner ,
ret = > $ ret ,
} ;
2022-01-16 12:17:11 +01:00
print FILE "operator adr update preview with bonusnr:\n" . Dumper ( $ adr_bonus ) . "\n" ;
$ ret = $ pl - > set_usertarif ( $ dbh , $ operator_conf - > { database } - > { dbname } , $ adr_bonus , $ bonus_collect ) ;
2022-02-16 15:56:45 +01:00
} else {
$ ret = "failure::txt15#top7" ;
2021-12-30 12:05:56 +01:00
}
} else {
$ ret = "failure::txt15#top5" ;
}
} elsif ( $ valxx && $ valxx =~ /\w+/ ) {
$ ret = "failure::txt15#top6" ;
}
}
}
#sharee txt30=Tarif (multible) and Bonusnummer txt15 automatic
elsif ( $ _ eq "txt30" ) {
#only done by Operator DMS
if ( $ varenv { dbname } ne "sharee_primary" ) {
my @ txt30 = $ q - > param ( 'txt30' ) ; #multiple select sharee Tarif
@ txt30 = grep { ! /null/ } @ txt30 ;
my $ bonusnr = $ q - > escapeHTML ( "$R::txt15" ) ; #on Operator DMS without oprefix-
my $ bonushash = {
table = > "contentadr" ,
mtime = > "now()" ,
c_id = > $ c_id ,
txt15 = > $ bonusnr ,
txt30_array = > \ @ txt30 ,
owner = > $ owner ,
ret = > $ ret ,
} ;
$ ret = $ pl - > set_usertarif ( $ dbh , $ varenv { dbname } , $ bonushash ) ;
}
#phonenr
} elsif ( $ _ eq "txt07" ) {
$ valxx =~ s/[\s\-\/]//g ;
2022-01-10 12:33:49 +01:00
if ( $ valxx !~ /\d{9}/ || length ( $ valxx ) > 16 ) {
2021-12-30 12:05:56 +01:00
$ ret = "failure::$_#top" ;
} else {
#smsAck reset
if ( $ valxx ne $ ctadr - > { txt07 } ) {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "int13=0" ) ;
}
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_='$valxx'" ) ;
my $ email = $ R:: txt08 ;
$ email =~ s/\s//g ;
my $ confirm_digest = sha1_base64 ( $ email . $ valxx ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt34='$confirm_digest'" ) ;
}
#user alias email
} elsif ( $ _ eq "txt08" ) {
$ valxx =~ s/\s//g ;
if ( $ valxx !~ /\w\@\w/ ) {
$ ret = "failure::$_#top" ;
} else {
my $ account_check = & check_account ( "" , "txt08" , "ilike" , $ valxx , "c_id" , "!=" , $ c_id ) ;
print FILE "$account_check->{c_id} && $account_check->{c_id} != $c_id\n" if ( $ debug ) ;
if ( $ account_check - > { c_id } && $ account_check - > { c_id } != $ c_id ) {
2022-01-14 19:41:45 +01:00
my $ encoded_val = $ uri_encode - > encode ( $ valxx ) ;
$ ret_conflict = "failure::conflict_$_=$encoded_val#top" ;
2021-12-30 12:05:56 +01:00
}
#mailAck reset
if ( $ valxx ne $ ctadr - > { txt08 } ) {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "int04=0" ) ;
}
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_='$valxx'" ) ;
}
2022-02-23 20:30:12 +01:00
} elsif ( $ _ eq "int12" && $ varenv { dbname } ne "sharee_primary" ) {
my $ vde_on_fail = 0 ;
$ vde_on_fail = 2 if ( $ valxx && $ valxx == 1 ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_=$vde_on_fail" ) ;
2021-12-30 12:05:56 +01:00
} elsif ( $ _ =~ /^int|barcode/ ) {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_=$valxx" ) ;
} elsif ( $ _ eq "ct_name" && $ R:: base_edit ) {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_='$valxx'" ) ;
#}elsif($_ !~ /ct_name|txt22|txt23|txt15/){
} elsif ( $ _ !~ /ct_name|txt15/ ) {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "$_='$valxx'" ) ;
}
#Additionals after default updater
#on IBAN/BIC change set override Mandantsreferenz to c_id to trigger payone
if ( ( $ _ eq "txt22" && $ valxx ne $ ctadr - > { txt22 } ) || ( $ _ eq "txt23" && $ valxx ne $ ctadr - > { txt23 } ) ) {
$ u_rows += $ dbt - > update_one ( $ dbh , $ update_primary , "ct_name='$c_id'" ) ;
}
if ( $ _ =~ /txt22/ && $ valxx ) {
my $ currency = "EUR" ;
$ currency = "CHF" if ( $ valxx =~ /^(CH)/i ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt24='$currency'" ) ;
}
print FILE "-----> $_: $valxx\n" if ( $ debug ) ;
$ ret = "failure::$_#top" if ( ( $ _ =~ /int14/ ) && ( $ valxx eq "null" || ! $ valxx ) ) ; #sharee AGB
#Zahlungsart
$ ret = "failure::$_#top" if ( ( $ _ =~ /int03/ ) && ( $ valxx eq "null" || ! $ valxx ) ) ;
$ ret = "failure::$_#top" if ( $ _ =~ /txt01/ && $ valxx !~ /[a-zäöü]+\s+[a-zäöü]+/i ) ;
$ ret = "failure::$_#top" if ( $ _ =~ /txt03/ && ( $ valxx !~ /[\w|\.]+\s+\d+/ && $ valxx !~ /\d+\s+[\w|\.]+/ ) ) ;
if ( $ _ =~ /txt04/ && ! $ pw_dummy ) {
my $ alphacount = 0 ;
my $ alphafail = 0 ;
$ alphacount = ( ) = $ valxx =~ /[a-z]/gi ;
$ alphafail = length ( $ valxx ) - $ alphacount ;
if ( ! $ valxx || length ( $ valxx ) < 8 || $ alphafail < 2 ) {
#$ret = "failure::pwlazy_txt04#top";
$ ret = "failure::$_#top" ;
}
}
$ ret = "failure::$_#top" if ( $ _ =~ /txt06/ && $ valxx !~ /\d+\s+[a-zäöü]+/i ) ;
$ ret = "failure::$_#top" if ( $ _ =~ /txt08/ && $ valxx !~ /\w\@\w/ ) ;
$ ret = "failure::$_#top" if ( $ R:: sharee_edit && $ _ =~ /txt22/ && $ valxx !~ /\w/ ) ;
$ ret = "failure::$_#top" if ( $ R:: sharee_edit && $ _ =~ /txt23/ && $ valxx !~ /\w/ ) ;
}
print FILE "ret: $ret | ret_conflict: $ret_conflict\n" if ( $ debug && ( $ ret || $ ret_conflict ) ) ;
} #end foreach keyword
#payone only if SEPA Mandat checked
#Testbuchhung mit 1 € preauthorization and 0 € capture
$ ctadr = $ dbt - > fetch_record ( $ dbh , $ authref ) ;
print FILE "+++ $R::request && $ctadr->{int03} == 1 && $ctadr->{ct_name} eq $ctadr->{c_id} \n" if ( $ debug ) ;
if ( $ R:: request eq "managemandate" && $ ctadr - > { int03 } == 1 && $ ctadr - > { ct_name } eq $ ctadr - > { c_id } ) {
my $ vde_on_fail = $ ctadr - > { int12 } || 3 ; #keep last or set 3
my $ payone_mival = $ payone - > managemandate_main ( \ % varenv , $ ctadr , "" , $ owner ) ;
if ( $ payone_mival && $ payone_mival =~ /\w{2}-\d+/ ) {
#define fictiv invoice to get 1 € test
my $ epoche = time ( ) ;
my $ ctt = {
c_id = > 1 ,
int01 = > 0 ,
int15 = > 1 ,
txt16 = > "" ,
reference = > "$ctadr->{c_id}_$epoche" ,
2022-02-22 08:31:35 +01:00
payone_reset = > ''
2021-12-30 12:05:56 +01:00
} ;
2022-01-16 12:17:11 +01:00
2021-12-30 12:05:56 +01:00
my $ payone_txid = "" ;
2022-01-16 12:17:11 +01:00
##preauthorization and/or capture needs to much time, must be done async!
#$payone_txid = $payone->preauthorizationSEPA_main(\%varenv,$ctadr,$ctt,$owner);
#if($payone_txid)
if ( 1 == 1 ) {
2021-12-30 12:05:56 +01:00
$ ctt - > { txt16 } = "$payone_txid" ;
2022-01-16 12:17:11 +01:00
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "int12=0" ) ; #Vde
#$payone_txid = $payone->captureSEPA_main(\%varenv,$ctadr,$ctt,$owner);
#int12=0 should be set after capture success in payment module
2021-12-30 12:05:56 +01:00
} else {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "int12=$vde_on_fail" ) ; #Vde
}
} else {
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "int12=$vde_on_fail" ) ; #Vde
}
#$u_rows = $dbt->update_one($dbh,$update_primary,"int12=3");#Vde test fail
}
if ( $ R:: txt04 && $ R:: confirm_txt04 && $ R:: txt04 ne $ R:: confirm_txt04 ) {
$ ret = "failure::confirm_txt04#top" ;
}
if ( $ ret =~ /failure::(\w+)/ && $ ret !~ /txt15|txt16/ ) { #persistent failure without Bonus or Gutschein
my $ rval = $ 1 ;
#$rval =~ s/pwlazy_//g;#obsolet, all done in pw template description
$ rval =~ s/confirm_//g ; #PW confirm
$ rval =~ s/conflict_//g ; #conflict
print FILE "ret: $ret | rval: $rval\n" if ( $ debug ) ;
$ dbt - > update_one ( $ dbh , $ update_primary , "txt31='$rval'" ) ;
} elsif ( $ fkeys =~ /$ctadr->{txt31}/ ) {
print FILE " No failure and empty txt31 (fkeys: $fkeys =~ /$ctadr->{txt31}/) \n" if ( $ debug ) ;
$ u_rows = $ dbt - > update_one ( $ dbh , $ update_primary , "txt31=''" ) ;
}
$ ret = $ ret_conflict if ( $ ret_conflict ) ;
print FILE "final ret: $ret \n" if ( $ debug ) ;
close ( FILE ) if ( $ debug ) ;
#if(!$ret){#we do it also on failures to get sync
#update operator with primary data after COPRI address edit
$ dbt - > update_operatorsloop ( $ varenv { dbname } , $ ctadr - > { c_id } , "update" ) ;
return ( $ ret , "$i_rows-$u_rows-$d_rows" ) ;
}
#insert/save/delete DMS users
sub manage_dmsusers {
my $ self = shift ;
my $ base_edit = shift ;
my $ u_id = shift ;
my $ users_dms = shift || { } ;
my $ owner = $ users_dms - > { u_id } || 0 ;
my $ table = "users" ;
$ q = new CGI ;
$ q - > import_names ( 'R' ) ;
my @ keywords = $ q - > param ;
my $ now_dt = strftime "%Y-%m-%d %H:%M:%S" , localtime ;
my % varenv = $ cf - > envonline ( ) ;
$ bw - > log ( "manage_dmsusers" , $ q , "" ) ;
my $ dbh = "" ;
my $ authref = {
table = > "contentadr" ,
fetch = > "one" ,
template_id = > "202" ,
c_id = > "$u_id" ,
} ;
my $ ctadr = $ dbt - > fetch_record ( $ dbh , $ authref ) ;
#users have to be exist only if DMS activated
my $ uref = {
table = > "users" ,
fetch = > "one" ,
u_id = > "$u_id" ,
} ;
my $ users = $ dbt - > fetch_tablerecord ( $ dbh , $ uref ) ;
#datahash on update
my $ dmsusers = {
table = > "users" ,
mtime = > "now()" ,
owner = > "$owner" ,
u_id = > "$u_id" ,
} ;
if ( ref ( $ users ) eq "HASH" && $ users - > { u_id } && ( ! $ ctadr - > { c_id } || $ base_edit eq "delete_dmsusers" ) ) {
$ bw - > log ( "delete DMS user from $varenv{dbname}" , $ ctadr - > { c_id } , "" ) ;
$ d_rows += $ dbt - > delete_content ( $ dbh , "users" , $ u_id ) ;
} elsif ( ref ( $ users ) eq "HASH" && $ users - > { u_id } && $ ctadr - > { c_id } && $ ctadr - > { c_id } == $ users - > { u_id } && $ base_edit eq "save_dmsusers" ) {
$ bw - > log ( "update DMS user to $varenv{dbname}" , $ ctadr - > { c_id } , "" ) ;
foreach ( @ keywords ) {
my $ val = $ q - > param ( $ _ ) ;
my $ valxx = $ q - > escapeHTML ( "$val" ) ;
$ valxx =~ s/^\s+// ; $ valxx =~ s/\s+$// ;
if ( $ _ =~ /^int\d+/ ) {
$ valxx =~ s/,/./g ;
#$valxx = "null" if(!looks_like_number($valxx));#empty
$ valxx = 0 if ( ! looks_like_number ( $ valxx ) ) ; # set to 0 for using == operator
$ u_rows = $ dbt - > update_one ( $ dbh , $ dmsusers , "$_=$valxx" ) ;
}
}
} elsif ( $ ctadr - > { c_id } && ! $ users - > { u_id } && $ base_edit eq "new_dmsusers" ) {
$ bw - > log ( "insert DMS user to $varenv{dbname}" , $ ctadr - > { c_id } , "" ) ;
$ i_rows = $ dbt - > insert_users ( $ dbh , $ ctadr - > { c_id } , $ owner ) ;
}
return "$i_rows-$u_rows-$d_rows" ;
}
#coupon alias Gutschein
sub save_transact () {
my $ self = shift ;
my ( $ c_id , $ coo , $ owner ) = @ _ ;
$ q = new CGI ;
$ q - > import_names ( 'R' ) ;
my @ keywords = $ q - > param ;
my $ now_dt = strftime "%Y-%m-%d %H:%M:%S" , localtime ;
my % varenv = $ cf - > envonline ( ) ;
$ bw - > log ( "save_transact" , $ q , "" ) ;
my $ debug = 1 ;
my $ dbh = "" ; #keep in mind, empty dbh defaults to local copri-instance dbname
open ( FILE , ">>$varenv{logdir}/save_account.log" ) if ( $ debug ) ;
print FILE "\n*-->local copri-Instance DB $varenv{dbname} $now_dt| c_id: $c_id \n" if ( $ debug ) ;
my $ authref = {
table = > "contentadr" ,
fetch = > "one" ,
template_id = > "202" ,
c_id = > "$c_id" ,
} ;
my $ ctadr = $ dbt - > fetch_record ( $ dbh , $ authref ) ;
my $ pos_id = "" ;
my $ ret ;
my $ fkeys ;
foreach ( @ keywords ) {
$ fkeys . = "$_," ;
my $ val = $ q - > param ( $ _ ) ;
my $ valxx = $ q - > escapeHTML ( "$val" ) ;
#print "|$_: $valxx";
$ valxx =~ s/^\s+// ;
$ valxx =~ s/\s+$// ;
#Gutschein
if ( $ _ eq "txt16" ) {
print FILE "Gutschein request $_: $valxx\n" if ( $ debug ) ;
if ( $ valxx && ( $ valxx =~ /^(\w{2,3})-(\w+)/ || $ valxx =~ /^(\w{2,3})(\d+)/ ) ) {
$ valxx =~ s/\s//g ;
my $ coupon_prefix = uc ( $ 1 ) ,
my $ coupon_nr = $ 2 ;
my $ operator_conf = $ dbt - > get_operator_conf ( $ coupon_prefix ) ;
if ( ref ( $ operator_conf ) eq "HASH" && $ operator_conf - > { oprefix } && $ operator_conf - > { database } - > { dbname } ) {
print FILE "Gutschein $valxx : " . $ operator_conf - > { oprefix } . " " . $ operator_conf - > { database } - > { dbname } . "\n" if ( $ debug ) ;
my $ dbh_operator = $ dbt - > dbconnect_extern ( $ operator_conf - > { database } - > { dbname } ) ;
#to get operator coupon_nr
my $ pref_co = {
table = > "content" ,
fetch = > "one" ,
template_id = > "224" ,
int03 = > ">::0" ,
2022-02-10 16:45:22 +01:00
ct_name = > "ilike::$coupon_nr" ,
2021-12-30 12:05:56 +01:00
} ;
my $ ct = { c_id = > 0 } ;
$ ct = $ dbt - > fetch_record ( $ dbh_operator , $ pref_co ) ;
$ ct - > { int02 } *= - 1 if ( $ ct - > { int02 } > 0 ) ; #coupon price must be negate
print FILE "txt16=$coupon_nr, unit_price $ct->{int02} --> requested on web on: $operator_conf->{database}->{dbname} --> barcode:$ct->{barcode}\n" if ( $ debug ) ;
if ( $ ct - > { c_id } ) {
my $ ctadr_operator = { c_id = > 0 } ;
$ ctadr_operator = $ dbt - > fetch_record ( $ dbh_operator , $ authref ) ;
if ( ! $ ctadr_operator - > { c_id } ) {
2022-05-17 06:13:53 +02:00
my % operator_hash = ( ) ;
if ( $ ctadr - > { txt17 } && $ ctadr - > { txt17 } =~ /\w\s\w/ ) { #append DB's
% operator_hash = map { $ _ = > 1 } split ( /\s+/ , $ ctadr - > { txt17 } ) ;
} elsif ( $ ctadr - > { txt17 } ) {
$ operator_hash { $ ctadr - > { txt17 } } = 1 ;
}
$ operator_hash { $ operator_conf - > { database } - > { dbname } } = 1 ;
my @ operator_array = keys % operator_hash ;
$ bw - > log ( "save_transact update operator keys by array: @operator_array" , \ % operator_hash , "" ) ;
print FILE "save_transact update operator keys by array: @operator_array | pri $ctadr->{c_id}\n" if ( $ debug ) ;
my $ update_primary = {
table = > "contentadr" ,
txt17 = > "@operator_array" , #operator ids
txt19 = > "$operator_conf->{database}->{dbname}" ,
atime = > "now()" ,
owner = > "198" , #update initiated by primary
} ;
my $ rows = $ dbt - > update_record ( $ dbh , $ update_primary , $ ctadr ) ;
2021-12-30 12:05:56 +01:00
print FILE "Gutschein oprefix address INSERT adr from record_primary to operator $operator_conf->{database}->{dbname} , c_id:$ctadr->{c_id}\n" ;
my $ insert_op = {
%$ ctadr ,
table = > "contentadr" ,
mtime = > 'now()' ,
owner = > "198" ,
} ;
my $ c_id_op = $ dbt - > insert_contentoid ( $ dbh_operator , $ insert_op , "reset_adropkeys" ) ;
}
$ ctadr_operator = $ dbt - > fetch_record ( $ dbh_operator , $ authref ) ;
if ( $ ctadr_operator - > { c_id } > 0 ) {
my $ pref = {
table = > "contenttrans" ,
fetch = > "one" ,
main_id = > 300008 , #must be Rechnung (and not Storno)
template_id = > 218 ,
#ca_id => "$ctadr->{c_id}",
int10 = > "$ctadr_operator->{c_id}" ,
state = > "is::null" ,
close_time = > "is::null" ,
} ;
my $ ctt = { c_id = > 0 } ;
$ ctt = $ dbt - > fetch_record ( $ dbh_operator , $ pref ) ;
2022-05-11 19:01:13 +02:00
my $ posref = {
table = > "contenttrans" ,
table_pos = > "contenttranspos" ,
fetch = > "one" ,
keyfield = > "c_id" ,
ca_id = > "$ctadr->{c_id}" ,
ct_name = > "ilike::$valxx" ,
} ;
my $ cttpos = { c_id = > 0 } ;
$ cttpos = $ dbt - > collect_post ( $ dbh_operator , $ posref ) ;
#check if user has still coupon used
2022-05-19 06:35:50 +02:00
#if(!$cttpos->{c_id}){#disabled
if ( 1 == 1 ) {
2022-05-11 19:01:13 +02:00
if ( $ ctt - > { c_id } > 0 ) {
$ pos_id = $ dbt - > insert_pos ( $ dbh_operator , $ ctt - > { c_id } , $ ct , $ ctadr_operator , "" , $ now_dt , $ valxx , "0" , $ owner ) ;
} else {
my $ ct_id = { c_id = > 0 } ;
$ ct_id = $ dbt - > insert_contenttrans ( $ dbh_operator , $ ctadr_operator , "300008" , "218" , "----" , $ owner ) ;
$ pos_id = $ dbt - > insert_pos ( $ dbh_operator , $ ct_id , $ ct , $ ctadr_operator , "" , $ now_dt , $ valxx , "0" , $ owner ) ;
}
} else {
$ ret = "failure::conflict_txt16#top" ;
}
2021-12-30 12:05:56 +01:00
if ( $ pos_id ) {
$ ret = "success::txt16" ;
$ dbt - > update_content4comp ( $ dbh_operator , $ ct - > { c_id } , "-" , "1" ) ;
}
} else {
$ ret = "failure::txt16#top" ;
}
} else {
$ ret = "failure::txt16#top" ;
}
}
} elsif ( $ valxx && $ valxx =~ /\w+/ ) {
$ ret = "failure::txt16#top" ;
}
}
}
print FILE "save_transact ret: $ret \n" if ( $ debug ) ;
close ( FILE ) if ( $ debug ) ;
return $ ret ;
} #end save_transact
#Send sms after payable check and !int13
sub smsack () {
my $ self = shift ;
my $ ctadr = shift ;
$ smstrans - > sms_ack_digest ( $ ctadr ) ;
}
#Send email after payable check and !int04
sub emailack () {
my $ self = shift ;
my $ c_id = shift ;
my % varenv = $ cf - > envonline ( ) ;
system ( `$varenv{basedir}/src/Mod/newsletter_tink.pl "$varenv{basedir}" "$varenv{wwwhost}" "emailack" "$c_id" ""` ) ;
}
#Password forgotten send email
sub send_password () {
my $ self = shift ;
my ( $ email , $ coo , $ owner ) = @ _ ;
my % varenv = $ cf - > envonline ( ) ;
$ email = $ q - > escapeHTML ( $ email ) ;
$ email =~ s/\s//g ;
2022-03-12 08:21:41 +01:00
$ bw - > log ( "$varenv{basedir}/src/Mod/newsletter_tink.pl" , $ email , "" ) ;
2021-12-30 12:05:56 +01:00
my $ pwmd5 = md5_hex ( $ coo ) ;
2022-03-12 08:21:41 +01:00
#don't change/hassle pw on tester for ex. apple@sharee.bike|google@sharee.bike
if ( $ email && $ email !~ /$dbt->{copri_conf}->{test_accounts}/i ) {
$ db - > updater ( "contentadr" , "1" , "1" , "txt11" , "$pwmd5" , "$owner" , "txt08" , "ilike" , "$email" ) ;
system ( `$varenv{basedir}/src/Mod/newsletter_tink.pl "$varenv{basedir}" "$varenv{wwwhost}" "send_password" "$email" "$coo"` ) ;
}
2021-12-30 12:05:56 +01:00
}
2022-05-11 08:05:35 +02:00
#sigbike just like caching and not realy used by app
sub sigbike_cupdate {
2022-04-04 14:57:43 +02:00
my $ self = shift ;
2022-05-11 08:05:35 +02:00
my $ record_sig = shift ;
2022-04-04 14:57:43 +02:00
my $ dbh = "" ;
my $ rows = 0 ;
2022-05-11 08:05:35 +02:00
foreach my $ bid ( keys ( %$ record_sig ) ) {
2022-04-04 14:57:43 +02:00
my $ update = {
2022-05-11 08:05:35 +02:00
% { $ record_sig - > { $ bid } } ,
2022-04-04 14:57:43 +02:00
table = > "content" ,
template_id = > "205" ,
main_id = > "300102" ,
mtime = > "now()" ,
owner = > "169" ,
} ;
2022-05-11 08:05:35 +02:00
$ bw - > log ( "UPDATE content from record_sig with bike nr:" , $ update , "" ) ;
$ rows = $ dbt - > update_record ( $ dbh , $ update , $ record_sig - > { $ bid } ) ;
2022-04-04 14:57:43 +02:00
if ( $ rows != 1 ) {
my $ c_id = "" ;
2022-04-05 12:29:58 +02:00
$ update - > { itime } = "now()" ;
2022-05-11 08:05:35 +02:00
$ bw - > log ( "INSERT content from record_sig with bike nr:" , $ update , "" ) ;
2022-04-05 12:29:58 +02:00
$ c_id = $ dbt - > insert_contentoid ( $ dbh , $ update , "" ) ;
$ rows = 1 if ( $ c_id ) ;
}
}
return $ rows ;
}
2022-05-11 08:05:35 +02:00
#sigstation just like caching and not realy used by app
sub sigstation_cupdate {
2022-04-05 12:29:58 +02:00
my $ self = shift ;
2022-05-11 08:05:35 +02:00
my $ record_sig = shift ;
2022-04-05 12:29:58 +02:00
my $ dbh = "" ;
my $ rows = 0 ;
2022-05-11 08:05:35 +02:00
foreach my $ sid ( keys ( %$ record_sig ) ) {
2022-04-05 12:29:58 +02:00
my $ update = {
2022-05-11 08:05:35 +02:00
% { $ record_sig - > { $ sid } } ,
2022-04-05 12:29:58 +02:00
table = > "content" ,
template_id = > "225" ,
main_id = > "300016" ,
mtime = > "now()" ,
owner = > "169" ,
} ;
2022-05-11 08:05:35 +02:00
$ bw - > log ( "UPDATE content from record_sig with bike nr:" , $ update , "" ) ;
$ rows = $ dbt - > update_record ( $ dbh , $ update , $ record_sig - > { $ sid } ) ;
2022-04-05 12:29:58 +02:00
if ( $ rows != 1 ) {
my $ c_id = "" ;
$ update - > { itime } = "now()" ;
2022-05-11 08:05:35 +02:00
$ bw - > log ( "INSERT content from record_sig with bike nr:" , $ update , "" ) ;
2022-04-05 12:29:58 +02:00
$ c_id = $ dbt - > insert_contentoid ( $ dbh , $ update , "" ) ;
2022-04-04 14:57:43 +02:00
$ rows = 1 if ( $ c_id ) ;
}
}
return $ rows ;
}
2021-12-30 12:05:56 +01:00
1 ;
