/******************************************* Module DBeditor Server Version: 1.0 Author: Thierry LEFORT Last update: 05/28/2001 *******************************************/ var EDITFLAG=0;;var DBFLAG=1;;var SELECT=1;; var UPDATE=2;; var INSERT=3;; var DELETE=4;; var QUERY=5;; typeof Alias = S ;; /*ODBC variables*/ typeof Login = S ;; typeof Password = S ;; typeof Table = S ;; typeof MetaTableAttr = S ;; typeof MetaTable = S ;; typeof db= SqlDB ;; /*Data Base*/ typeof table = S ;; typeof CLIENTID = I ;; typeof insert = I ;; typeof flagBD = I ;; typeof ListAccess = [I r1] ;; typeof ListChamps = [S r1] ;; /*Structure de donnée qui transporte les informations nécessaires ((nom du champs)::(type du champs)::(niveau de sec)::nil):: */ typeof ListInfoBD = [[S r1] r1] ;; typeof key = S ;; typeof listUSER = [User r1];; defcom SsendColumns = sendColumns S;; defcom SsendMaxId = sendMaxId S;; defcom SErrorDB = ErrorDB S;;/*Send an error message to client*/ defcom SinsertDB = insertDB ;;/*Acknoledge insert*/ defcom SmodifDB = modifDB ;;/*Acknoledge modif*/ defcom SdeleteDB = deleteDB ;;/*Acknoledge delete*/ defcom StooMuchLines = tooMuchLines I ;; defcom SerrorSelectBDD = errorSelectBDD ;; defcom SMiseAjour = MiseAjour ;; defcom SRefreshNOSELECT = RefreshNOSELECT ;; defcom streamedclientcom = getstreamedmessage S;; /* Communication streamed !*/ /*DB access Variables*/ var FULLACCESS = 0 ;; var READONLY = 1 ;; var NOACCESS = 2 ;; var KEY = 3 ;; var SELECTQUERY = "" ;; var MessageMaxSize = 8192;;/*Taille du paquet limité à 8ko*/ defcom Srefresh=refresh;; /*************************************************************************** Renvoie le login ou le password d'une base de donnees, on specifie l'alias dans odbcAlias, l'info que l'on souhaite reccueillir dans info ("login" ou "password") les valeurs sont recuperees dans usmress.ini format : odbc.odbcAlias.login odbc.odbcAlias.password attention : odbcAlias, infos ne doivent pas contenir les caracteres suivants : ".*?" ****************************************************************************/ fun GetODBCInfos(odbcAlias,info)= hd switchstr strextr _loadressini strcatn "odbc."::odbcAlias::"."::info::nil ;; fun testDB (MyClient)= let SqlCod db ->Result in if Result == SQL_ERROR then ( let SqlDescErr db -> [etat native message lignes] in _DMSsend this MyClient SErrorDB [message]; SqlRollback db; 0 ) else ( SqlCommit db; 1 ) ;; fun listlength(l)= if l==nil then 0 else let l->[_ n] in 1+listlength n;; /* Fonction de découpage*/ fun cut (cli,messagevalue,pos,lenght)= let pos + MessageMaxSize -> newpos in if newpos > lenght then _DMSsend this cli streamedclientcom [(substr messagevalue pos lenght-pos)]/*If the message is One it's the last paquet send*/ else ( _DMSsend this cli streamedclientcom [(substr messagevalue pos MessageMaxSize)]; cut cli messagevalue newpos lenght ) ;; /* fonction à utiliser pour envoyer des gros messages */ fun _DMSSendStm(cli,param)= cut cli param 0 (strlen param) ;; /*Receive de SELECT request and send the lines to the client*/ fun __SELECTquery(SELECT) = let SqlRequest db SELECT nil -> tmp in if (testDB DMSsender) == 1 then let listlength tmp -> nb_lines in if (nb_lines) > 100 then _DMSsend this DMSsender StooMuchLines [nb_lines] else ( _DMSSendStm DMSsender (strbuild tmp) ) else _DMSsend this DMSsender SerrorSelectBDD [] ;; /*********************************************************************************************/ /********** DATA CREATION FOR PRODUCTS *******************/ /*********************************************************************************************/ /*********************************************************************************************/ fun testString(string)= if !strcmp string nil then "" else string ;; /*********************************************************************************************/ /********** DB REQUEST TOOLS *******************/ /*********************7************************************************************************/ fun getReadAccess (listAttr, listAccess) = if listAttr == nil || listAccess == nil then nil else ( let (hd listAccess) -> tmp in if tmp == NOACCESS then getReadAccess tl listAttr tl listAccess else let (hd hd listAttr) -> elem in if tmp == READONLY then ((elem)::(hd tl hd listAttr)::(itoa READONLY)::nil)::(getReadAccess tl listAttr tl listAccess) else if tmp == KEY then ( set key = elem; ((elem)::(hd tl hd listAttr)::(itoa KEY)::nil)::(getReadAccess tl listAttr tl listAccess) ) else (elem::(hd tl hd listAttr)::(itoa FULLACCESS)::nil)::(getReadAccess tl listAttr tl listAccess) ) ;; /*Send to the client the list of the columns readable*/ fun __queryTable() = let SqlRequest db "GET_COLUMNS" (SQL_NIL Table)::nil -> listATTR in let getReadAccess listATTR ListAccess -> columns in let listcat (Table::"rien"::"rien"::nil)::nil columns -> Tcolumns in ( _DMSsend this DMSsender SsendColumns [strbuild Tcolumns]; set ListInfoBD = columns ) ;; /*Send the Id for a new element*/ fun __queryMaxId() = if insert then _DMSsend this DMSsender SsendMaxId ["auto"] else let strcatn "SELECT "::MetaTableAttr::" FROM "::MetaTable::nil -> req in let hd hd SqlRequest db req nil -> tempid in let (if tempid==nil then "0" else tempid) -> max_id in let itoa ((atoi max_id) + 1 ) -> max_id1 in let strcatn "UPDATE "::MetaTable::" SET "::MetaTableAttr::"="::max_id1::nil -> UpDateReq in let SqlRequest db UpDateReq nil -> MetaUpdate in _DMSsend this DMSsender SsendMaxId [max_id1] ;; fun broad (users) = if users ==nil then nil else ( _DMSsend this UtoC hd users SMiseAjour []; broad tl users; 1 ) ;; fun cbRefresh (from, user, action, param, others, tag) = broad listUSER ;; /******************************************************************************* the client has been disconnected cli -> CLIENT : the client <- I : nothing special (always 0) *******************************************************************************/ fun cbLogoutClient (cli) = _DMSeventTag this CtoU cli "out" nil nil nil; 0 ;; /******************************************************************************* destroy a client from -> DMI : not used user -> User : the user that run the action action -> S : not used param -> S : not used others -> [User r1] : not used tag -> Tag : not used <- I : nothing special *******************************************************************************/ fun cbDestroy (from, user, action, param, others, tag) = let UtoC user -> cli in ( _DMSdelClientDMI this cli; _DMSeventTag this user "out" nil nil nil ) ;; /******************************************************************************* create a client from -> DMI : not used user -> User : the user that run the action action -> S : not used param -> S : parameters of the action others -> [User r1] : not used tag -> Tag : not used <- I : nothing special *******************************************************************************/ fun cbStart (from, user, action, param, others, tag) = if _DMScreateClientDMI this UtoC user nil then ( _DMSeventTag this user "entering" nil nil nil; if flagBD == 1 then 0 else ( _DMSsend this UtoC user SErrorDB [(_loc this "KW_BD_DEAD" nil)]; 1 ); ) else nil ;; fun SR1TOIR1 (SR1) = if SR1 == nil then nil else (atoi hd SR1)::(SR1TOIR1 tl SR1) ;; /******************************************************************************* the client part of the module has been deleted cli -> CLIENT : the client <- I : nothing special (always 0) *******************************************************************************/ fun cbDeleteClient (cli) = _DMSeventTag this CtoU cli "out" nil nil nil; set listUSER = remove_from_list listUSER CtoU cli; 0 ;; /******************************************************************************* the module instance will be closed (server and all client parts) cli -> CLIENT : the client <- I : always 0 (not used) *******************************************************************************/ fun cbBeforeClose () = 0 ;; /******************************************************************************* main function, called when the server part of the module is initialized file -> S : not used <- I : nothing special *******************************************************************************/ fun IniDMI2 (file) = let strextr _getpack _checkpack file ->param in ( set Alias = (getInfo param "alias"); set Login= GetODBCInfos Alias "login"; set Password = GetODBCInfos Alias "password"; if (set db = SqlCreate _channel testString Alias testString Login testString Password) == nil then set flagBD = 0 else set flagBD = 1; SqlSetAttr db AUTOCOMMIT_OFF ; set Table = (getInfo param "table"); set MetaTable = (getInfo param "MetaTable"); set MetaTableAttr = (getInfo param "MetaTableAttr"); set insert = atoi (getInfo param "insert"); set ListAccess = SR1TOIR1 lineextr (getInfo param "accessList") ); _DMSregister this @cbLogoutClient @cbDeleteClient nil; /*@cbBeforeClose*/ _DMSdefineActions this (["start" @cbStart ]):: (["destroy" @cbDestroy ]):: (["refreshfromDB" @cbRefresh ]):: nil ;; fun pro () = let BigToAsc BigInvn BigFromAsc _getpack _checkpack "dms/db/dbeditor/dbeditor.conf" BigFromAsc "c8aa22856afe3a01" -> s in let if (strlen s)!=9 then nil else [htoi substr s 1 4 htoi substr s 5 4] -> [datedebut periode] in if periode==nil then (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_INVALID_MSG" nil)::nil;0) else if periode==0 then 1 else let ((time>>1)&0x3fffffff)/43200-datedebut -> x in if x<0 then (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_INVALID_MSG" nil)::nil;0) else if x<=periode then (_addwarning strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_LIMITED_MSG" (itoa (periode-x))::nil)::nil;1) else (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_ENDLIMITED_MSG" nil)::nil;0) ;; /* Server initialisation */ fun IniDMI (f) = if pro then IniDMI2 f else nil ;; /*********************************************************************************************/ /********** CALLBCAK DE MISE A JOUR DBR *******************/ /*********************************************************************************************/ fun AdjustEmptyS(str)= if !strcmp str "" then "arianenil" else str;; fun AdjustEmptyI(int)= if !strcmp int "" then "-1" else int;; fun list_attr_to_string(list, param)= if list == nil then nil else if (listlength list) == 1 then hd hd list else strcatn (hd hd list)::param::(list_attr_to_string tl list param)::nil ;; fun point_interro(num) = { if num<=1 then "?" else strcat "?," (point_interro (num-1)) };; fun string_to_fun_SQL (typesql, elem)= if !strcmp typesql "SQL_BIGINT" then SQL_BIGINT AdjustEmptyI elem else if !strcmp typesql "SQL_BIT" then SQL_BIT elem else if !strcmp typesql "SQL_DATE" then SQL_DATE elem else if !strcmp typesql "SQL_DECIMAL" then SQL_DECIMAL AdjustEmptyI elem else if !strcmp typesql "SQL_DOUBLE" then SQL_DOUBLE AdjustEmptyI elem else if !strcmp typesql "SQL_FLOAT" then SQL_FLOAT AdjustEmptyI elem else if !strcmp typesql "SQL_INTEGER" then SQL_INTEGER AdjustEmptyI elem else if !strcmp typesql "SQL_NUMERIC" then SQL_NUMERIC AdjustEmptyI elem else if !strcmp typesql "SQL_REAL" then SQL_REAL AdjustEmptyI elem else if !strcmp typesql "SQL_SMALLINT" then SQL_SMALLINT AdjustEmptyI elem else if !strcmp typesql "SQL_TIME" then SQL_TIME elem else if !strcmp typesql "SQL_TIMESTAMP" then SQL_TIMESTAMP elem else if !strcmp typesql "SQL_TINYINT" then SQL_TINYINT AdjustEmptyI elem else if !strcmp typesql "SQL_BINARY" then SQL_BINARY elem else if !strcmp typesql "SQL_VARBINARY" then SQL_VARBINARY elem else if !strcmp typesql "SQL_LONGVARBINARY" then SQL_LONGVARBINARY elem else if !strcmp typesql "SQL_LONGVARCHAR" then SQL_LONGVARCHAR AdjustEmptyS elem else if !strcmp typesql "SQL_VARCHAR" then SQL_VARCHAR AdjustEmptyS elem else if !strcmp typesql "SQL_CHAR" then SQL_CHAR AdjustEmptyS elem else /*if !strcmp typesql "SQL_MONEY" then SQL_MONEY elem else*//*A rajouter lorsque le type SQL_MONEY existera*/ nil ;; fun mkParamModif (list_new_elem) = { if list_new_elem == nil then nil else ( let hd list_new_elem -> tmp in let hd tmp -> type in let hd tl tmp -> elem in ( (string_to_fun_SQL type elem)::(mkParamModif tl list_new_elem) ) ) };; fun RemoveKey (list) = if list == nil then nil else let hd list -> tete in let hd tete -> NomAttr in if !strcmp NomAttr key then tl list else listcat tete::nil (RemoveKey tl list) ;; fun getKeyValue (list) = if list == nil then "" else let hd list -> tete in let hd tete -> NomAttr in let hd tl tl tete -> contenu in if !strcmp NomAttr key then contenu else getKeyValue tl list ;; fun BuildUpDateRequest (list) = if list==nil then nil /*S*/ else let hd list -> tete in let hd tete -> NomAttr in let hd tl tl tete -> contenu in if !strcmp NomAttr key then ( BuildUpDateRequest tl list /*S*/ ) /* strcatn "UPDATE product_description SET "::(list_attr_to_string list_tmp "= ?,")::"=? WHERE productid= ?"::nil*/ else if (listlength list) != 1 then strcatn NomAttr::" = ?,"::(BuildUpDateRequest tl list)::nil /*S*/ else strcatn NomAttr::" = ? "::(BuildUpDateRequest tl list)::nil /*S*/ ;; fun BuildInsertRequest (list) = if list==nil then nil /*S*/ else let hd list -> tete in let hd tete -> NomAttr in let hd tl tl tete -> contenu in if (listlength list) != 1 then strcatn NomAttr::", "::(BuildInsertRequest tl list)::nil /*S*/ else strcatn NomAttr::(BuildInsertRequest tl list)::nil /*S*/ ;; fun ParamSQLreqUpDate (list_new_elem) = if list_new_elem == nil then nil else ( let hd list_new_elem -> tmp in let hd tmp -> name in let hd tl tmp -> type in let hd tl tl tmp -> elem in ( if !strcmp name key then ParamSQLreqUpDate tl list_new_elem else (string_to_fun_SQL type elem)::(ParamSQLreqUpDate tl list_new_elem) ) ) ;; fun __cancelDBtransact()= 0 ;; fun __ModifyDBline(Strlist_param)= let strextr Strlist_param -> list_param in let BuildUpDateRequest list_param -> req in let getKeyValue list_param -> rekey in let strcatn "UPDATE "::Table::" SET "::req::" WHERE "::key::"= "::rekey::nil -> UpDateQuery in let ParamSQLreqUpDate list_param -> tmp in ( SqlRequest db UpDateQuery tmp; if (testDB DMSsender) == 1 then ( _DMSsend this DMSsender SmodifDB []; 1 ) else 0 ) ;; fun ParamSQLreq (list_new_elem) = if list_new_elem == nil then nil else ( let hd list_new_elem -> tmp in let hd tl tmp -> type in let hd tl tl tmp -> elem in (string_to_fun_SQL type elem)::(ParamSQLreq tl list_new_elem) ) ;; fun __NewDBline(list)= let strextr list -> list_param in let if insert then RemoveKey list_param else list_param -> ltmp in let BuildInsertRequest ltmp -> req in let strcatn "INSERT INTO "::Table::" ("::req::") VALUES ("::(point_interro (listlength ltmp))::")"::nil -> InsertReq in let ParamSQLreq ltmp -> tmp in ( SqlRequest db InsertReq tmp; if (testDB DMSsender) == 1 then ( _DMSsend this DMSsender SinsertDB []; 1 ) else 0 ) ;; fun IDtoSQL (list) = if list==nil then nil /*S*/ else let hd list -> tete in if (IDtoSQL tl list ) != nil then strcatn tete::","::(IDtoSQL tl list)::nil /*S*/ else strcatn tete::(IDtoSQL tl list)::nil /*S*/ ;; fun __DelDBlines(name, listID)= let IDtoSQL (lineextr listID) -> tmp in let strcatn "DELETE * FROM ["::Table::"] WHERE ["::Table::"].["::name::"] IN ("::tmp::")"::nil -> DelReq in SqlRequest db DelReq nil; if (testDB DMSsender) == 1 then ( _DMSsend this DMSsender SdeleteDB []; 1 ) else 0 ;;