Rev 13 | Blame | Compare with Previous | Last modification | View Log | RSS feed
<%doc>
# ---------------------------------------------------------------------- #
# Copyright: (C) 2002 Leader.IT S.r.l. <http://leader.it>
# Authors: Guido Brugnara <gdo@leader.it>
# Mario Claudio Pisoni <pisoni@leader.it>
#
# $Revision: 18 $
# ---------------------------------------------------------------------- #
</%doc>
<%perl>
# ==================================== Share functions =====================================================
# ============================================================================== Uses
use POSIX ":sys_wait_h";
use Symbol;
use IO::Select;
use IPC::Open3;
use IO::File;
use DBI;
# =============== check if two arrays has the same contents
sub sameContent($$){
my ($ref1, $ref2) = @_;
my $found = '';
if ( scalar(@$ref1) != scalar(@$ref2) ){
return($found);
}
foreach my $cur1 (@$ref1){
foreach my $cur2 (@$ref2){
if ($cur1 eq $cur2){
$found = 'TRUE';
last;
}
}
}
return($found);
}
# ============================================================================= writeMsg
sub writeMsg($$){
my($message, $curfunc) = @_;
my $LOGfile = '[[log_message_error_path]][[log_message_error_filename]]';
if(! $MAIN::log_cms){
`echo 'opening from run'>>[[log_message_error_path]][[log_message_error_filename]]`;
$MAIN::log_cms = new IO::File;
$MAIN::log_cms->open(">>$LOGfile") or die "Error opening file $LOGfile: $!";
$MAIN::log_cms->autoflush(1);
}
my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
my $time = sprintf("%04d/%02d/%02d %02d:%02d:%02d", 1900+$year, $mon+1, $mday, $hour, $min, $sec);
print $MAIN::log_cms "$time>$curfunc:$message\n" or warn "on print file $LOGfile: $!";
# $MAIN::log_cms->close;
}
# ============================================================================== Esecuzione
sub Esecuzione{
# Esecuzione(5, 'ls', '-l');
my $timeout = shift;
my $input = gensym();
my $error = gensym();
my $output = gensym();
my($status, $out, $err);
# lancio il processo
my $pid = open3($input, $output, $error, @_);
my $sel = new IO::Select($output,$error);
LOOP: for(;;){
my @ready = $sel->can_read($timeout);
if(!@ready){
warn "Timeout read from host";
return (-1,$out,$err);
}
foreach my $h (@ready){
my $r = <$h>;
if($r){
if($h eq $output){
$out.=$r;
}elsif($h eq $error){
$err.=$r;
}else{
die "Handle $h unexpected";
}
}else{
$sel->remove($h);
if(!$sel->count()){
last LOOP;
}
}
}
}
if(waitpid($pid,&WNOHANG)){
$status = ($? & 0xff00)/256;
}else{
$status = 0;
}
return ($status, $out, $err);
}
# ============================================================================== checkExec
sub checkExec($$) {
my $caller = shift;
my($cmd) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('100', ' 1:', ' 40:', '');
#### $s - status, $o - stdout, $r stderr
my($s, $o, $r) = Esecuzione(8, $cmd);
my $ret = '';
if ($s eq '0'){ ### No errors
chomp($o);
$ret = 'OK_'.$o;
$message = "in CheckExec, cmd= @_ out=$ret";
writeMsg($message, $dbginfo . $caller. $curfunc);
}elsif ($s eq '1'){ ### Error
$message = "Error on @_, status=$s, out=$o, err=$r";
writeMsg($message, $dbgerror . $caller. $curfunc);
}elsif ($s eq '-1'){ ### Time out
$message = "Time out on @_, status=$s, out=$o, err=$r";
writeMsg($message, $dbgerror . $caller. $curfunc);
}else{ ### Error Number > 1 on exit
$message = "Error on @_, status=$s, out=$o, err=$r";
writeMsg($message, $dbgerror . $caller. $curfunc);
}
return $ret;
}
sub rollbackCmd($$){
# ============================== exec all the command in the array of commands, BUT for the same argument!!!
my ($ref_cmd, $arg) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('101', ' 1:', ' 40:', '');
my $wasError = '';
foreach my $curcmd (@$ref_cmd){
my $ret=checkExec($curfunc, "su1 cms_command $curcmd $arg");
if(! $ret ){
$wasError .= "Incorrect in $curcmd,";
}
}
return($wasError);
}
# ============================================================================== readFileIntoArray
sub readFileIntoArray($$$){
# ======= read a file, reverse if is needed and return N lines
my ($filename, $isReverse, $cantLines) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('123', ' 1:', ' 50:', 'OK');
my $retArray;
if (! open(FH, '<', $filename)){
$retArray = "file:$filename, $!";
writeMsg("cant open file:$filename:, $!", $dbgerror . $curfunc);
return($retArray);
}
my $prevInputRecordSeparator = undef $/;
$retArray = <FH>;
# ### make a comment to turn on the ligths ' >
$/ = $prevInputRecordSeparator;
# $usrTraffic =~ s/\n//g;
close FH;
my @tmpArray = split "\n", $retArray;
my $limit;
if(! $cantLines){
$limit = $#tmpArray;
}else{
$limit = $cantLines;
}
# ### reverse the array, Im shure there is another way to doit ;)
my @tempA;
if($isReverse){
foreach my $line ( reverse @tmpArray){
if(! $limit){
last;
}
push @tempA, $line;
$limit --;
}
}else{
foreach my $line ( @tmpArray){
if(! $limit){
last;
}
push @tempA, $line;
$limit --;
}
}
$retArray = join "", @tempA;
return($retArray);
}
# ============================================================================== Proccess form fields
sub processPOST($$) {
my $function = shift;
my $ref_ARGS = shift;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('122', ' 1:', ' 50:', 'OK');
my ($setfields, $setvalues) = ('','');
my $isFirstime = 1;
my @tmparr = [];
my $fieldsNotProcess = '';
foreach my $curkey (keys %$ref_ARGS){
if($curkey =~ /_HIDE_/){
next; ### skiping hidden field
}
if($curkey =~ /ROW./){
push(@tmparr, %$ref_ARGS->{$curkey});
next;
}
if($curkey =~ /FL\.(.+)/){
if($function eq 'update'){
if($1 =~ /_CHECK/){
# ============== is a buton Check =====
$setvalues = $curkey;
next;
}
if($1 =~ /_SELECT/){
# ============== is a Select Option =====
$setvalues = $curkey;
next;
}
if($isFirstime){
$setvalues = "$1='" . %$ref_ARGS->{$curkey} ."'";
$isFirstime = '';
next;
}
$setvalues = $setvalues . ", $1='" . %$ref_ARGS->{$curkey} ."'";
}else{
if($isFirstime){
$setfields .= "$1";
$setvalues .= "'" . %$ref_ARGS->{$curkey} . "'";
$isFirstime = '';
next;
}
$setfields .= ", $1";
$setvalues .= ", '" . %$ref_ARGS->{$curkey} . "'";
}
}
# propably there are some fields that are not trated here
$fieldsNotProcess .= "$curkey,";
}
if($fieldsNotProcess){
writeMsg("fieldsNotProcess:$fieldsNotProcess:", $dbginfo . $curfunc);
}
if($function eq 'update'){
return($setvalues);
}else{
return("($setfields) values ($setvalues)");
}
}
# ============================================================================== ADUClassListStr
sub ADUClassListStr($$$){
my ($function, $value, $newitemvalue) = @_;
my $retvalue = '';
my $found = '';
my $firstime = 'TRUE';
my ($newname, $newteacher, $newflag, $newcuraula, $newclasspersis) = split /:/, $newitemvalue;
my @classes = split /\s+/, $value;
#writeMsg("value=$value", "100");
my ($curfunc,$dbgerror,$dbginfo,$message) = ('123', ' 1:', ' 40:', '');
# ========================== Process all the active classes, [$classid:$teacherid:$flag] ...
foreach my $curclass ( @classes ){
my ($name, $teacher, $flag, $curaula, $classpersis) = split /:/, $curclass;
#writeMsg("curclass=$curclass", "100");
if( $name =~ m/$newname/ ){
$found = 'TRUE';
if($function eq 'ADD_FLAG' ){
if($flag !~ m/$newflag/){
$flag .= $newflag;
}
if($newteacher ne '_PREV_VALUE_'){
$teacher = $newteacher;
}
$curclass = "$name:$teacher:$flag:$curaula:$classpersis";
}elsif($function eq 'UPD_AULA'){
$curclass = "$name:$teacher:$flag:$newcuraula:$newclasspersis";
}elsif($function eq 'DELETE_FLAG'){
$flag =~ s/$newflag//;
if($newteacher ne '_PREV_VALUE_'){
$teacher =~ s/$newteacher//;
}
$curclass = "$name:$teacher:$flag:$curaula:$classpersis";
}elsif($function eq 'DELETE'){
$curclass = '';
}else{
$message = "Error: function:$function unknown\n";
writeMsg($message, $dbgerror . $curfunc);
}
}
if($firstime){
$retvalue = $curclass;
$firstime = '';
}else{
$retvalue .= ' ' . $curclass;
}
}
if(! $found ){
$message = "Error: flag:$newflag didn't find on keys\n";
writeMsg($message, $dbgerror . $curfunc);
$retvalue = undef;
}
return($retvalue);
}
# ========================================================================================
# ======================================= DB FUNCTIONS ===================================
# ========================================================================================
# ============================================================================== getDbConnect
sub getDbConnect($$){
my ($autoCommit,$raiseError) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('102', ' 1:', ' 40:', 'OK');
if(!$autoCommit){
$autoCommit = 1;
}
if(!$raiseError){
$raiseError = 1;
}
my $dbh_cms = DBI->connect([[DB_StrConnect]]) or die "Cant connect dbh_cms;" . $DBI::strerr;
DBI->trace(1, '[[log_trace_dbconnect]]');
# DBI->trace(1);
$dbh_cms->{RaiseError} = $raiseError;
$dbh_cms->{AutoCommit} = $autoCommit;
$dbh_cms->do('set DateStyle to SQL, EUROPEAN');
return($dbh_cms);
}
# ============================================================================== getField
sub getField($$$$){
my ($tbname, $field, $condition, $conditionvalue) = @_;
my $dbh = getDbConnect(1,1);
return(_getField($dbh, $tbname, $field, $condition, $conditionvalue));
}
# ============================================================================== _getField
sub _getField($$$$$){
my ($dbh, $tbname, $field, $condition, $conditionvalue) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('103', ' 1:', ' 40:', 'OK');
my $value;
my $curSQL = "select $field from $tbname $condition";
my $sth = $dbh->prepare($curSQL);
my $ret = $sth->execute($conditionvalue);
if (! $ret){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
$value = $ret;
}else{
$value = $sth->fetchrow_array;
}
writeMsg($message, (($ret)? $dbginfo:$dbgerror) . $curfunc);
return($value);
}
# ============================================================================== updateField1
sub updateField1($$$$$){
my ($tbname, $field, $condition, $conditionvalue, $value) = @_;
my $set = "$field=?";
if($tbname eq 'keys'){
$set = "id=nextval('keys_id'), $field=?";
}
return(updateField($tbname, $set, $condition, $conditionvalue, $value));
}
# ============================================================================== updateField
sub updateField($$$$$){
my ($tbname, $set, $condition, $conditionvalue, $value) = @_;
my $dbh = getDbConnect(1,1);
return(_updateField($dbh, $tbname, $set, $condition, $conditionvalue, $value));
}
# ============================================================================== _updateField1
sub _updateField($$$$$$){
my ($dbh, $tbname, $set, $condition, $conditionvalue, $value) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('104', ' 1:', ' 40:', 'OK');
my $curSQL = "update $tbname set $set $condition";
my $sth = $dbh->prepare($curSQL);
my $ret = $sth->execute($value, $conditionvalue);
if ($ret eq "0E0"){
$message = "error ret:$ret:, on $curSQL ($value, $conditionvalue); errstr:" . $dbh->errstr;
$ret = 0;
}
writeMsg($message, (($ret)? $dbginfo:$dbgerror) . $curfunc);
return($ret);
}
# ============================================================================== insertRecord
sub insertRecord($$){
my ($tbname, $condition) = @_;
my $dbh = getDbConnect(1,1);
return(_insertRecord($dbh, $tbname, $condition));
}
# ============================================================================== insertRecord
sub _insertRecord($$$){
my ($dbh, $tbname, $condition) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('105', ' 1:', ' 40:', 'OK');
my $curSQL = "insert into $tbname $condition";
my $sth = $dbh->prepare($curSQL);
my $ret = $sth->execute();
if (! $ret){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
}
writeMsg($message, (($ret)? $dbginfo:$dbgerror) . $curfunc);
return($ret);
}
# ============================================================================== deleteRecord
sub deleteRecord($$$){
my ($tbname, $condition, $conditionvalue) = @_;
my $dbh = getDbConnect(1,1);
return(_deleteRecord($dbh, $tbname, $condition, $conditionvalue));
}
# ============================================================================== deleteRecord
sub _deleteRecord($$$$){
my ($dbh, $tbname, $condition, $conditionvalue) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('106', ' 1:', ' 40:', 'OK');
my $curSQL = "delete from $tbname $condition";
my $sth = $dbh->prepare($curSQL);
my $ret = $sth->execute($conditionvalue);
if (! $ret){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
}
writeMsg($message, (($ret)? $dbginfo:$dbgerror) . $curfunc);
return($ret);
}
# ============================================================================== modifyFieldDataFunction
sub modifyFieldDataFunction($$$){
my ($value, $function, $functionargs) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('34b', ' 1:', ' 40:', '');
my $newvalue;
#writeMsg("MAPI fargs=$functionargs=", $dbginfo . $curfunc);
#writeMsg("MAPI value=$value=", $dbginfo . $curfunc);
if($function eq 'deleteClass'){
my $classid = $functionargs;
$newvalue = ADUClassListStr('DELETE', $value, "$classid:_PREV_VALUE_:_PREV_VALUE:_PREV_VALUE_:_PREV_VALUE");
}elsif($function eq 'insertVipUsr'){
my $usrid = $functionargs;
$newvalue = $value;
if($value !~ m/$usrid/){
$newvalue = $value . " $usrid";
}
}elsif($function eq 'deleteVipUsr'){
my $usrid = $functionargs;
$newvalue = $value;
if($value =~ m/$usrid/){
$newvalue =~ s/$usrid//;
}
}elsif($function eq 'deleteFM'){
my $fm = $functionargs;
$newvalue = $value;
if($value =~ m/$fm/){
$newvalue =~ s/\s*$fm//;
}
}elsif($function eq 'insertFM'){
chomp($value);
$newvalue = $value . "$functionargs";
}elsif($function eq 'insertClass'){
chomp($value);
my $tmpargs = $functionargs;
if($functionargs =~ m/_BLANK_/){
$tmpargs =~ s/_BLANK_//;
#writeMsg("MAPI tmpargs=$tmpargs=", $dbginfo . $curfunc);
}
$newvalue = $value . " $tmpargs";
}elsif($function eq 'updateClass'){
$newvalue = $value . " $functionargs";
}elsif($function eq 'updateClassAula'){
my ($classid, $status, $newflag, $curaula, $classpersis) = split /:/, $functionargs;
if($classpersis =~ m/_BLANK_/){
$classpersis =~ s/_BLANK_//;
}
$newvalue = ADUClassListStr('UPD_AULA', $value, "$classid:_PREV_VALUE_:_PREV_VALUE_:$curaula:$classpersis");
}elsif($function eq 'updateClassFlag'){
my ($classid, $status, $newflag, $curaula, $classpersis) = split /:/, $functionargs;
#$m->out(Dumper($functionargs));
if($status =~ m/[[class_status_active]]/ ){
$newvalue = ADUClassListStr('ADD_FLAG', $value, "$classid:_PREV_VALUE_:$newflag:_PREV_VALUE_:_PREV_VALUE");
}else{
$newvalue = ADUClassListStr('DELETE_FLAG', $value, "$classid:_PREV_VALUE_:$newflag:_PREV_VALUE_:_PREV_VALUE");
}
# =========== used by class ==========
}elsif($function eq 'OFF'){
$newvalue = $value;
if($value =~ m/$functionargs/){
$newvalue =~ s/$functionargs//;
}
}elsif($function eq 'ON'){
$newvalue = $value . "$functionargs";
}else{
writeMsg("Error:rich case default on $function", $dbgerror . $curfunc);
}
return($newvalue);
}
# ============================================================================== updateDbField
sub modifyFieldData($$$$$$){
my ($tablename, $field, $condition, $conditionvalue, $function, $functionargs) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('34b', ' 1:', ' 40:', '');
my $dbh = getDbConnect(1,1);
# ===================================================================== Begin Transaction
$dbh->begin_work or writeMsg("cant begin trans".$dbh->errstr, $dbgerror . $curfunc);
my $ret = _modifyFieldData($dbh, $tablename, $field, $condition, $conditionvalue, $function, $functionargs);
if(! $dbh->commit){
$dbh->rollback or writeMsg("cant commit".$dbh->errstr, $dbgerror . $curfunc);
writeMsg("Cant commit ".$dbh->errstr, $dbgerror . $curfunc);
}else{
writeMsg("OK", $dbginfo . $curfunc);
}
return($ret);
}
# ============================================================================== updateDbField
sub _modifyFieldData($$$$$$$){
my ($dbh, $tablename, $field, $condition, $conditionvalue, $function, $functionargs) = @_;
my ($sth, $ret, $curSQL);
my ($key, $value, $newvalue);
my ($curfunc,$dbgerror,$dbginfo,$message) = ('34', ' 1:', ' 40:', '');
# ==================================================== Get the value to update
$curSQL = "select $field from $tablename $condition";
$sth = $dbh->prepare($curSQL);
$ret = $sth->execute($conditionvalue);
if (! $ret){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
writeMsg($message, $dbgerror . $curfunc);
}
$value = $sth->fetchrow_array;
# ==================================================== Process the value with function
$newvalue = modifyFieldDataFunction($value, $function, $functionargs);
if($newvalue eq undef){
return(0);
}
# ==================================================== Process the value with function
if($tablename eq 'keys'){
$curSQL = "update $tablename set id=nextval('keys_id'), $field=? $condition";
}else{
$curSQL = "update $tablename set $field=? $condition";
}
#$m->out( $curSQL);
$sth = $dbh->prepare($curSQL);
$ret = $sth->execute($newvalue, $conditionvalue);
if (! $ret){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
writeMsg($message, $dbgerror . $curfunc);
}
return($ret);
}
# ============================================================================== getUsrConnectInfo
sub getUsrConnectInfo($){
my ($field) = @_;
my $dbh = getDbConnect(1,1);
return(_getUsrConnectInfo($dbh, $field));
}
# ============================================================================== getUsrConnectInfo
sub _getUsrConnectInfo($$){
my ($dbh, $field) = @_;
my ($curfunc,$dbgerror,$dbginfo,$message) = ('107', ' 1:', ' 40:', 'OK');
my ($ret, $remoteIp);
if(%ENV->{'HTTP_X_FORWARDED_FOR'}){
$remoteIp= %ENV->{'HTTP_X_FORWARDED_FOR'};
}else{
$remoteIp= %ENV->{'REMOTE_ADDR'};
}
if($field eq 'profile'){
my $sth = $dbh->prepare_cached(<<SQL);
select profile from usr, classlayout where classlayout.usrid = usr.id and classlayout.pcip=?
SQL
# my $profile;
# $sth->bind_columns(undef, \$profile);
$sth->execute($remoteIp);
# $sth->fetch;
# $ret = $profile;
($ret) = $sth->fetchrow_array;
}else{
my $cmd = " select $field";
my $from = ' from usr, classlayout';
my $where = ' where classlayout.usrid = usr.id and classlayout.pcip=?';
my $curSQL = $cmd . $from . $where;
my $sth = $dbh->prepare($curSQL);
if(! $sth->execute($remoteIp) ){
$message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
writeMsg($message, (($ret)? $dbginfo:$dbgerror) . $curfunc);
}
($ret) = $sth->fetchrow_array;
}
return($ret);
}
# ============================================================================== getEnableStudentOfClass
sub getStudentOfClass($$){
my ($classid, $reason) = @_;
my $dbh = getDbConnect(1,1);
return(_getStudentOfClass($dbh, $classid, $reason));
}
# ============================================================================== getEnableStudentOfClass
sub _getStudentOfClass($$$){
my ($dbh, $classid, $reason) = @_;
my ($sth, $ret, $curSQL);
my ($curfunc,$dbgerror,$dbginfo,$message) = ('36', ' 1:', ' 40:', 'OK');
if($reason eq '4share'){
$curSQL = "select usrid from usrclass, usr where classid='$classid' and usrclass.profile='[[usr_profile_student]]' and usrclass.permision like '%[[usr_permision_SH]]%' and usrid=usr.id and usr.profile='[[usr_profile_student]]'";
}elsif($reason eq '4web'){
$curSQL = "select usrid from usrclass where classid='$classid' and profile='[[usr_profile_student]]' and permision like '%[[usr_permision_WW]]%' ";
}elsif($reason eq '4all'){
$curSQL = "select usrid from usrclass where classid='$classid' and profile='[[usr_profile_student]]'";
}else{
writeMsg("in Otherwise :$reason:", $dbgerror . $curfunc);
}
my $ref_usrid = $dbh->selectall_arrayref($curSQL);
if (! $ref_usrid){
my $message = "error, on $curSQL\n; errstr:" . $dbh->errstr;
writeMsg($message, $curfunc);
}else{
writeMsg("OK", $dbginfo . $curfunc);
}
my $listusr = '';
foreach my $curusr ( @$ref_usrid ){
$listusr .= ' ' . $curusr->[0];
}
return($listusr);
}
# ==================================== End Share functions =================================================
</%perl>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<META HTTP-EQUIV="content-type" CONTENT="text/html; charset=ISO-8859-15">
<META HTTP-EQUIV="Expires" CONTENT="now">
<title>
<& SELF:title &>
</title>
<link rel="stylesheet" href="/cms/include/styles.css?Rel=001" type="text/css">
</head>
%# <BODY BGCOLOR="<% $color %>">
<% $m->call_next %>
<& .footer &>
<%method title>
CMS (Classroom Management System) by Leader.IT S.r.l.
</%method>
<%init>
my $color = "#f1edd3";
$r->headers_out->add('Expires' => 'now');
$r->headers_out->add('Content-Language' => 'it_IT');
</%init>