⇧
Progression Fixer Avancement - 18/04/2025 19:31:09
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($progression : Integer; $data : Object)
// fixe l'avancement $1 de la tâche en cours du process courant
var $avancement : Real
// callBack de commande 4D
Case of
: ($data=Null)
: (Not(OB Is defined($data; "Time")))
: (Not(OB Is defined($data; "débutTache")))
: (Not(OB Is defined($data; "finTache")))
// il faut les données d'avancement
Else
// calcul de l'avancement
// v8.3.4 on gère une origine
Case of
: (Not(OB Is defined($data; "origine")))
// pour compatibilité
$avancement:=$progression/100
: ($data.origine="Commande4D_1640")
// commande 4D "Zip Créer Archive
// $1 est compris entre 0 et 100 (cf doc 4D)
$avancement:=$progression/100
Else
// process ALV
// $1 est compris entre 0 et 10000
$avancement:=$progression/10000
End case
Use ($data)
$data.Time:=$data.débutTache+(($data.finTache-$data.débutTache)*$avancement)
End use
End case
⇧
Exécuter Function Coopérative - 25/04/2025 12:31:52
#DECLARE($class : Object; $params : Object)->$result : Integer
var $trace : cs.Traces
var $nomProcess; $nomTache : Text
var $data : Object
$trace:=cs.Traces.new()
$result:=0
Case of
: (Not(OB Is defined($params; "functionID")))
$trace.CréerErreur("SDK"; -15068; Current method name; "'functionID' n'est pas défini dans $params").LeverException([msgk_event; msgk_log])
: (Value type($params.functionID)#Is text)
$trace.CréerErreur("SDK"; -15068; Current method name; "'$params.functionID' n'est pas un texte").LeverException([msgk_event; msgk_log])
: (Not(OB Is defined($params; "numProcessAppelant")))
$trace.CréerErreur("SDK"; -15068; Current method name; "'numProcessAppelant' n'est pas défini dans $params").LeverException([msgk_event; msgk_log])
: ($params.numProcessAppelant=-1)
$nomTache:=$params.nomTache
$nomProcess:="$ALV_process_"+$nomTache
If (OB Is defined($params; "nomProcess"))
$nomProcess:=$params.nomProcess
End if
// créer le nouveau process
$params.numProcessAppelant:=Current process
$result:=New process(Current method name; 0; $nomProcess; $class; $params; *)
Else
// c'est ok
InitProcess
// construire la classe
$data:=$class.new()
If ($data[$params.functionID]#Null)
// lancer le traitement demandé
$data[$params.functionID]($params)
Else
$trace.CréerErreur("SDK"; -15081; Current method name; "La classe "+$class.name+" n'est pas de function "+$params.functionID).LeverException([msgk_event; msgk_log])
End if
$result:=Current process
End case
⇧
Progression Process Composant - 19/04/2025 09:33:18
Partagée entre composants et base hôte
#DECLARE($numProc : Integer; $ProcInProgressStartTime : Integer; $ProcInProgressDuration : Integer; $numProgress : Integer)
var $ProcInProgressTime : Integer
var ProcInProgressTime; ProcInProgressState : Integer
var ProcInProgressEtat; ProcInProgressCmd : Text
Case of
: ($1>0)
// surveiller le process $1 {dans la barre $4}
// renvoie Vrai si l'utilisateur a purgé la tâche
If (Count parameters<4)
$numProgress:=0
End if
While (Process state($numProc)#Aborted)
// espionner le process $numProc
GET PROCESS VARIABLE($numProc; ProcInProgressEtat; ProcInProgressEtat; ProcInProgressTime; $ProcInProgressTime; ProcInProgressState; ProcInProgressState)
// mettre à jour l'avancement du thermomètre
ProcInProgressTime:=$ProcInProgressStartTime+($ProcInProgressDuration*$ProcInProgressTime/10000) // normalisation (/10000) * durée de la tâche
If ($numProgress>0)
// mettre à jour le libellé de l'état d'avancement
If (ProcInProgressEtat#"")
Progress SET PROGRESS($numProgress; ProcInProgressTime/10000; ProcInProgressEtat; False)
End if
// tuer le process à la demande de l'utilisateur
Case of
// il n'y a peut-être pas de btn
: (Not(Progress Get Button Enabled($numProgress)))
// action?
: (Not(Progress Stopped($numProgress)))
Else
// purger
SET PROCESS VARIABLE($numProc; ProcInProgressCmd; "Tuer process")
End case
End if
Waiting(10)
End while
End case
⇧
Partager Ressources - 27/07/2025 10:41:31
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($commande : Text; $data : Object)
// copier dans la base hôte les ressources $1 du composant appelant
// la méthode est appelée depuis un composant, typiquement :
// . appel depuis SDK : installation des ressources SDK dans un composant en développement, ou dans APP)
// . appel depuis un autre composant : installation des ressources du composant appelant dans la base hôte (a priori APP)
var $c; $liste : Collection
var $source; $destination : Object
var $itemText : Text
Case of
: ($commande="Installer Ressources Composant")
Case of
: (Not(OB Is defined($data; "dossier")))
: (Test path name($data.dossier)#Is a folder)
// pas de dossier à partager
: (Not(OB Is defined($data; "IDnom")))
// il faut un nom de composant
Else
$c:=Folder($data.dossier; fk platform path).folders(fk ignore invisible)
// recopier les chaines localisées partagées (fichiers "Composant_$data[IDnom].xlf"
$liste:=cs.Outils.me.ListerLanguesApplication().codes
// pour toutes les langues gérées par l'application
For each ($itemText; $liste)
Case of
: ($c.query("name"; $itemText).length=0)
// le dossier $itemText.lproj n'existe pas
: ($c.query("name"; $itemText)[0].files().length=0)
// il est vide
: ($c.query("name"; $itemText)[0].files().query("name"; "Composant_"+$data.IDnom).length=0)
// le fichier ressources "Composant_IDnom" n'existe pas
Else
$source:=Folder($data.dossier; fk platform path).file($itemText+".lproj/Composant_"+$data.IDnom+".xlf")
$destination:=Folder(Get 4D folder(Current resources folder; *); fk platform path).folder($itemText+".lproj")
//$destination.delete() // 16-09-2023 pb avec 'fk écraser'
// recopier
$source.copyTo($destination; fk overwrite)
End case
End for each
End case
Else
End case
⇧
InitProcess - 25/04/2025 12:32:28
// initialisation NON thread-safe
var $data : Object
// init des process (NON préemptifs, en particulier des workers)
ON ERR CALL(Formula(traceHandler).source; ek local)
ProcInProgressTime:=0
ProcInProgressState:=0
ProcInProgressEtat:=""
ProcInProgressCmd:=""
If (OB Is defined(Storage; "Processes"))
If (Not(OB Is defined(Storage.Processes; Current process name)))
Use (Storage.Processes)
Storage.Processes[Current process name]:=New shared object
End use
End if
$data:=Storage.Processes[Current process name]
Use ($data)
// infos du process courant
// commande reçue de l'extérieur
$data.Commande:=""
// état du process courant (partageable en lecture)
$data.Status:=New shared object
Use ($data.Status)
$data.Status.Time:=0
$data.Status.Etat:=""
$data.Status.State:=0
$data.Status.Waiting:=0
End use
// données du process courant (partageables)
$data.Data:=New shared object
// infos du process que le process courant a lancé
$data.ProcInProgress:=New shared object
$data.ProcInProgress.numProcess:=0
$data.ProcInProgress.name:=""
$data.ProcInProgress.Status:=New shared object
End use
Else
// init pas faite, le process courant est rapide !)
End if
⇧
Dupliquer ContenuDeDossier - 18/04/2025 19:39:18
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($source : Object; $destination : Object)
// recopier le contenu du dossier $1 dans le dossier $2
// remarque : 'copier Document' de 4D copie le dossier dans un dossier
var $fichier : 4D.File
var $dossier : 4D.Folder
Case of
: (Not($source.exists))
: (Not($destination.isFolder))
Else
// attention ici on copie un contenu de dossier, donc on ne touche pas au contenu initial
// recopier le contenu des dossiers
$destination.create()
// copier les documents
For each ($fichier; $source.files(fk ignore invisible))
$fichier.copyTo($destination; fk overwrite)
End for each
// copier les dossiers
For each ($dossier; $source.folders())
$dossier.copyTo($destination; fk overwrite)
End for each
End case
⇧
A Générer Composant - 12/04/2025 19:32:47
Partagée entre composants et base hôte
// exécuter dans un process externe
var $data : Object
var $numProc : Integer
$data:=New object
$data.functionID:="AfficherLaGeneration"
$data.nomProcess:="$SYS_Generation"
$data.nomTache:="$SYS_Generation"
$data.numProcessAppelant:=-1
$numProc:=Exécuter Function Coopérative(cs.$composant; $data)
// rappel : l'objet $data.tache a été créé
⇧
sharedObject - 18/04/2025 19:40:58
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($Obj_src : Object; $Obj_shared : Object)
var $Txt_property : Text
Use ($Obj_shared)
For each ($Txt_property; $Obj_src)
Case of
//______________________________________________________
: (Value type($Obj_src[$Txt_property])=Is object)
$Obj_shared[$Txt_property]:=New shared object
sharedObject($Obj_src[$Txt_property]; $Obj_shared[$Txt_property])
//______________________________________________________
: (Value type($Obj_src[$Txt_property])=Is collection)
$Obj_shared[$Txt_property]:=New shared collection
sharedCollection($Obj_src[$Txt_property]; $Obj_shared[$Txt_property])
//______________________________________________________
Else
$Obj_shared[$Txt_property]:=$Obj_src[$Txt_property]
//______________________________________________________
End case
End for each
End use
⇧
indexTableau - 18/04/2025 14:35:28
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($rang : Integer)->$result : Integer
// renvoie 0 (au lieu de -1)
$result:=Choose($rang<0; 0; $rang)
⇧
Bac à sable SDK - 02/07/2026 14:22:49
Partagée entre composants et base hôte
var $numProc; $i; $commande : Integer
var $MessageSource; $MessageLibellé; $MessageDescription; $path : Text
var $o; $oo; $ooo; $result : Object
var $Message : cs.Traces
var $c : Collection
Case of
: (Count parameters=0)
$numproc:=New process(Current method name; 0; "tester"+String(Random); Red; *)
: (Count parameters>0)
InitProcess
$o:=New object
$oo:=New object
$ooo:=New object
$c:=New collection()
//$c.push(5; 30)
//$c.push(31)
$commande:=0
For each ($i; $c)
$commande:=$commande ?+ $i
End for each
$o:=cs.EnvironnementALV.new()
//var $v : cs.Tache
//$v:=cs.RegistreTaches.me.Inscrire(New object("nomProcess"; Current process name; "nomTache"; "toto"; "numProcessAppelant"; Current process))
//$oo:=cs.RegistreTaches.me.LireProgressionTache("toto")
If (False)
$o:=Folder(fk documents folder).folder("tempo_ALV").file("DAZ-1.jpg")
var $svg:=cs.XML.me
var $xmlRef : Text
//$xmlRef:=SVG Créer(1378; 2269; "titre"; "description")
$xmlRef:=$svg.CréerArbreSVG(1378; 2269; "titre"; "description")
$path:=$SVG.AjouterImage($xmlRef; $o.platformPath)
$path:=$SVG.AjouterImage($xmlRef; $o.platformPath; 50; 100; 344; 567)
$path:=$svg.AjouterRectangle($xmlRef; 40; 40; 1200; 40)
$path:=$SVG.AjouterTexte($xmlRef; 50; 64; "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed non risus.")
DOM EXPORT TO VAR($xmlRef; $path)
DOM CLOSE XML($xmlRef)
TEXT TO DOCUMENT(Folder(fk documents folder).folder("tempo_ALV").file("test.svg").platformPath; $path)
$o:=Folder(fk documents folder).folder("tempo_ALV").file("DAZ-1.jpg")
$oo:=$o.copyTo(Folder(fk documents folder).folder("tempo_ALV"); "DAZ-1_filigrane.jpg"; fk overwrite)
cs.$document.new().Filigraner(New object("fichier"; $oo; "type"; 1); "Ainsi La Vie"; 20; 300; 90; "blue")
End if
//MARK: 05 FTP
If ($commande ?? 5)
$oo:=cs.ServicesFTP.new()
$MessageSource:="/AinsiLaVie/partage/"
$MessageSource:="/AinsiLaVie/partage/Photos/"
//$o:=$oo.ListerLesDocuments($MessageSource; ->$c)
$i:=1
$MessageLibellé:="x_4905.jpg"
$i:=2
//$MessageLibellé:="document.pdf"
//$MessageLibellé:="lettre.pdf"
$MessageSource:="/AinsiLaVie/partage/Photos/"+$MessageLibellé
$path:=Folder(fk home folder).folder("tempo_ALV/_SDKdebug").file($MessageLibellé).platformPath
$result:=$oo.RecevoirFichier($MessageSource; $path)
//GET DOCUMENT PROPERTIES($path; $loc; $invi; $dateO; $timeO; $adateM; $timeM)
SET DOCUMENT PROPERTIES($path; False; False; Date("2013-11-20T10:20:00.9854"); Time(10000); Date("2013-11-20T10:20:00.9854"); Time(10000))
$oo.Filigraner(New object("fichier"; File($path; fk platform path); "type"; $i); "Test de filigranage d'un document"; 40; 20; 0; "blue")
$MessageSource:="/AinsiLaVie/partage/Photos/x_1000.jpg"
$path:=Folder(fk home folder).folder("tempo_ALV/_SDKdebug").file("x_1000.jpg").platformPath
$result:=$oo.EnvoyerFichier($path; $MessageSource)
//$result:=$oo.getFileInfo($MessageSource)
$MessageSource:="/AinsiLaVie/partage/Photos/test2/"
$MessageSource:="/AinsiLaVie/siteWeb/test/"
//$result:=$oo.CréerRépertoire($MessageSource)
//$result:=$oo.ListerLesDocuments($MessageSource; ->$c)
//$result:=$oo.SupprimerRépertoire($MessageSource)
$MessageSource:="/AinsiLaVie/data/medias/folder_1"
ARRAY TEXT($tab; 0)
//$oo.LireCatalogueDuDossier($MessageSource; ->$result; ->$tab)
$ooo:=New object
$ooo.urlDossier:="/AinsiLaVie/data/medias/folder_15/"
$ooo.nomFichier:="03526.xfam.b64"
//$oo.TelechargerFichier($ooo; Dossier(Dossier système(Dossier personnel); fk chemin plateforme).folder("Tempo_FTP").folder("down").platformPath)
$MessageSource:=$ooo.urlDossier
//$oo.LireCatalogueDuDossier($MessageSource; ->$ooo)
//ALERTE(JSON Stringify($ooo; *))
End if
//MARK: 06 FTP
If ($commande ?? 6)
$o:=New object("params"; New object)
$o.nomClasse:="ServicesFTP"
$o.params.hébergement:="srv-sourderie.ainsilavie.fr"
$o.params.identifiant:="ainsilavie.fr-sourderie"
$o.params.motDePasse:="#mBeUt49Y-ZAMoXBHs@"
$o.params.timeOut:=30
$oo:=cs.xSDK.ServicesFTP.new($o)
$MessageSource:="/Albums_ALV/"
//$MessageSource:="/Albums_ALV/Famille_Brignou_-_Merrer/Mediasx/"
$o:=$oo.ListerLesDocuments($MessageSource; ->$c)
$MessageSource:="/Albums_ALV/Famille_Brignou_-_Merrer/Medias/1940-1965/006BEF1574EC4C1098123469D5646D08.jpg"
$MessageSource:="/Albums_ALV/Famille_Brignou_-_Merrer/Catalogue.json"
//$o:=$oo.getFileInfo($MessageSource; ->$ooo)
$MessageSource:="/AinsiLaVie/test/"
var $dossier : Object
$dossier:=Folder(System folder(Home folder); fk platform path).folder("Tempo_FTP")
//$o:=$oo.EnvoyerDossier($dossier; $MessageSource)
End if
//MARK: 07 FTP
If ($commande ?? 7)
$o:=New object("params"; New object)
$o.nomClasse:="ServicesFTP"
$o.params.hébergement:="srv-sourderie.ainsilavie.fr"
$o.params.identifiant:="ainsilavie.fr-sourderie"
$o.params.motDePasse:="#mBeUt49Y-ZAMoXBHs@"
$o.params.timeOut:=30
$ooo:=cs.xSDK.ServicesFTP.new($o)
$oo:=New object
$oo.nomTache:="toto"
$oo.cheminFTP:="/AinsiLaVie/data/medias/folder_0/"
$oo.cryptage:=New object("chemin"; "MacOS:Users:philippe:AinsiLaVie:Développement:BDD:Production:ALV Serveur Web.4dbase:Resources:"; "groupID"; -15001)
$oo.dossier:=Folder("MacOS:Users:philippe:AinsiLaVie:Data:Fichiers Media:Ajout de medias:"; fk platform path)
$oo.Options:=(0x0007 ?+ 6) ?+ 5
//$oo.calculAvancement:=Formule(test($1; 10; 100))
//$oo.tache:=csSDK New("RegistreTaches").Inscrire(Créer objet("nomProcess"; Nom du process courant; "nomTache"; $oo.nomTache))
//$ooo.MettreAjourDossier($oo)
$oo.cheminFTP:="/AinsiLaVie/data/update/v9_0/"
$oo.dossier:=Folder("MacOS:Users:philippe:Documents:Ainsi La Vie:Comptes Utilisateur:Auteur:ALV_DossierSession:ALVtempo_ExporterData:"; fk platform path)
$oo.Options:=0x0011
End if
//MARK: 09 messages
If ($commande ?? 9)
$message:=cs.Traces.new()
Case of
: (Count parameters=1)
Case of
: (Process number("U_formulaire?toto")=0)
// inits
EXECUTE METHOD(Current method name; *; Red; Orange; Green)
Else
CALL WORKER(Worker Services; Current method name; Red; Orange; Green; Yellow)
End case
: (Count parameters=3)
For ($i; 1; 9)
$message.EnvoyerMessages([msgk_event; msgk_log]; "SDK"; "libellé : "+String($i); "source : "+String($i); "description de "+String($i))
End for
$o:=New object("sourceLogs"; ALV Client APP; "wndTitre"; "toto"; "nbrMaxLogs"; 500)
cs.EvenementsALV.me.AfficherEditeur($o)
: (Count parameters=4)
$numProc:=Random
$message.EnvoyerMessages([msgk_event; msgk_log; msgk_instal]; "WEB"; "start erreurs "+String($numProc); "source "+Current method name; ",n k qzmd kerv akriz v,ez vrrkafbkne ckzbefkzvezv evlernoezvjevkrviubgv df,vekvz "+String($numProc); New object("nomProcess"; "Process Web"; "numProcess"; $numProc))
$message.EnvoyerMessages([msgk_event; msgk_log; msgk_instal]; "SDK"; "start erreurs "+String($numProc); "source "+Current method name; ",n k qzmd kerv akriz v,ez vrrkafbkne ckzbefkzvezv evlernoezvjevkrviubgv df,vekvz "+String(Current process); New object("nomProcess"; Current process name; "numProcess"; Current process))
$message.EnvoyerMessages([msgk_event; msgk_log; msgk_instal; msgk_debug]; "WEB"; "start "+String($numProc); "source "+Current method name; ",n k qzmd kerv akriz v,ez vrrkafbkne ckzbefkzvezv evlernoezvjevkrviubgv df,vekvz "+String($numProc); New object("nomProcess"; "Process Web"; "numProcess"; $numProc))
$message.EnvoyerMessages([msgk_event; msgk_log; msgk_instal; msgk_debug]; "SDK"; "start "+String($numProc); "source "+Current method name; ",n k qzmd kerv akriz v,ez vrrkafbkne ckzbefkzvezv evlernoezvjevkrviubgv df,vekvz "+String(Current process); New object("nomProcess"; Current process name; "numProcess"; Current process))
$message._EcrireLog()
End case
End if
//MARK: 10 cryptage
If ($commande ?? 10)
$oo.cryptage:=New object("groupID"; -15001)
$ooo:=Folder(fk documents folder).folder("tempo_ALV").folder("_SDKdebug")
$ooo.create()
$ooo:=$ooo.file("DAZ-1.jpg")
If ($ooo.exists)
$o:=cs.$document.new().CrypterALV($ooo; Null; $oo.cryptage)
$oo.cryptage:=New object("groupID"; -15001)
$ooo:=Folder(fk documents folder).folder("tempo_ALV").folder("_SDKdebug").file("DAZ-1.xfam")
$o:=cs.$document.new().DéCrypterALV($ooo; Null; $oo.cryptage)
Else
ALERT("le fichier "+Char(13)+$ooo.platformPath+Char(13)+" n'existe pas")
End if
End if
//MARK: 11 traces
If ($commande ?? 11)
Use (Storage.System)
Storage.System.estExecuteDansHote:=True
End use
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; -16001; Current method name; "test : service FTP KO")
$trace.ErrorLabel:=Localized string(String($message.Error))
$trace.LeverException([msgk_event])
Waiting(1)
$trace:=cs.Traces.new()
$trace.CréerErreur("SDK"; -15068; Current method name; "test : y manque un label")
$trace.ErrorLabel:=Localized string(String($message.Error))
$trace.LeverException([msgk_event])
Waiting(1)
var $heure : Time
$heure:=Create document(Folder(fk documents folder).folder("tempo_ALV").file("test").platformPath)
$heure:=Create document(Folder(fk documents folder).folder("tempo_ALV").file("test").platformPath)
$trace.EnvoyerMessages([msgk_event; msgk_log]; "SDK"; "Libellé 1"; Current method name; "test : Libellé 1")
Use (Storage.System)
Storage.System.estExecuteDansHote:=False
End use
End if
//MARK: 12 fichier
If ($commande ?? 12)
var $fichier : 4D.File
var $handle : 4D.FileHandle
$fichier:=cs.Traces.new().GetMessagesFichier()
$handle:=$fichier.open(New object("mode"; "append"; "charset"; "UTF-8"; "breakModeWrite"; Document with LF))
If ($handle.getSize()=0)
$handle.writeLine("Créé le "+String(Current date)+", à "+String(Current time))
$handle.writeLine("")
End if
For ($i; 1; 10)
$handle.writeLine("toto "+String($i)+" "+String(Timestamp))
End for
$o:=New object()
$o.toto:="jk mjk o o kmj mkj "
$o.titi:="k khkbkbh"
$handle.writeLine(JSON Stringify($o; *))
End if
//MARK: 30 console
If ($commande ?? 30)
$o:=New object("sourceLogs"; ALV Client APP; "wndTitre"; "toto"; "nbrMaxLogs"; 500)
cs.EvenementsALV.me.AfficherEditeur($o)
End if
//MARK: 31 traduc
If ($commande ?? 31)
cs.TraductionsEditeur.new().ModifierTraductions()
End if
End case
⇧
sharedCollection - 18/04/2025 19:43:07
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($Col_src : Collection; $Col_shared : Collection)
var $i : Integer
Use ($Col_shared)
For ($i; 0; $Col_src.length-1; 1)
Case of
//______________________________________________________
: (Value type($Col_src[$i])=Is object)
$Col_shared[$i]:=New shared object
sharedObject($Col_src[$i]; $Col_shared[$i])
//______________________________________________________
: (Value type($Col_src[$i])=Is collection)
$Col_shared[$i]:=New shared collection
sharedCollection($Col_src[$i]; $Col_shared[$i])
//______________________________________________________
Else
$Col_shared[$i]:=$Col_src[$i]
//______________________________________________________
End case
End for
End use
⇧
traceHandler - 14/03/2025 19:22:21
Capable de process préemptif
// la méthode a deux rôles :
// - traiter les erreurs interceptée par ON ERR CALL
// - exécuter une function de cs.Traces dans un worker
// les paramètres sont dans $trace !
#DECLARE($trace : cs.Traces; $functionID : Text)
var ErrorNum : Integer
Case of
: (Count parameters=0)
// interception d'une erreur
ErrorNum:=cs.Traces.new().Intercepter("SDK"; Error; Error method; Error line; Error formula)
: (Not(OB Is defined($trace; $functionID)))
// pb function, passer
Else
// exécuter $functionID sur la trace $trace
$trace[$functionID]()
End case
⇧
Waiting - 30/01/2026 19:26:44
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($EndTicks : Integer)
// $EndTicks : Durée en ticks, rappel 1 tick = 1/60 s
var $StartTicks : Integer
$StartTicks:=Tickcount
Repeat
IDLE
DELAY PROCESS(Current process; 1)
Until ((Tickcount-$StartTicks)>=$EndTicks)
⇧
ErrorHandler - 11/02/2025 14:43:53
Partagée entre composants et base hôte
Capable de process préemptif
// do nothing, just to fetch errors
// used in cs.FileTransfer._runWorker()
// utilisé par BDDmère
⇧
EcrireElement - 02/04/2025 09:42:04
Disponible via les balises HTML et les URLs 4D (4DACTION...)
Capable de process préemptif
#DECLARE($url : Text)->$texte : Text
// traiter toutes les url envoyées par un formulaire en construction
var $export : cs.ExportCode4D
var $result : Object
$export:=cs.ExportCode4D.new()
$result:=$export._TraiterURL($url)
// renvoyer le resultat
$texte:=$result.resultat
⇧
CodeEnreg - 18/04/2025 10:33:37
Partagée entre composants et base hôte
Capable de process préemptif
#DECLARE($itemRef : Integer; $c : Collection)->$result : Integer
// n° d'enregistrement codé --> n° du code (0 si pas codé)
// n° d'enregistrement, n° de table --> enreg. codé
// n° d'enregistrement codé ; ( {n°table} ) --> 1 (vrai) / 0 (faux)
var $codeItemRef; $numTable : Integer
var $isOK : Boolean
$result:=-2 //erreur appel
$codeItemRef:=($itemRef & 0xFF000000) >> 24
Case of
: (Count parameters=0)
: (Count parameters=1)
$result:=$codeItemRef
: ($c.length=0)
: ($codeItemRef=0) // coder un enregistrement
$result:=($c[0] << 24) | $itemRef
Else
// décoder un enregistrement
$isOK:=False
For each ($numTable; $c)
Case of
: ($numTable=160) // un enfant
$isOK:=$isOK | (($codeItemRef & 0x00E0)=$numTable) //supprimer les 5 derniers bits
: (($numTable=128) | ($numTable=144)) //une union / un parent
$isOK:=$isOK | (($codeItemRef & 0x00F0)=$numTable) //supprimer les 4 derniers bits
: (($numTable=200) | ($numTable=208)) //un media / une ressource
$isOK:=$isOK | (($codeItemRef & 0x00F8)=$numTable) //supprimer les 3 derniers bits
Else
$isOK:=$isOK | ($codeItemRef=$numTable)
End case
End for each
$result:=Num($isOK)
End case
⇧
Fenêtre du process - 18/04/2025 12:35:57
#DECLARE($currentProcess : Integer)->$result : Integer
// renvoie le num de la première fenêtre trouvée pour le process $1
var $i; $numProc : Integer
ARRAY LONGINT($FenList; 0)
WINDOW LIST($FenList; *) // inclure les fenêtres flottantes!
$result:=-1
$i:=Size of array($FenList)
While ($i>0)
$numProc:=Window process($FenList{$i})
If ($numProc=$currentProcess)
$result:=$FenList{$i}
$i:=0
End if
$i:=$i-1
End while
⇧
ProgressCallback - 31/07/2023 07:26:26
// called from cs.FileTransfer if callback is set via .useCallback()
// $ID is set through code - $message comes from curl
// shared object to pass progress ID back/forth and to share stop button result
#DECLARE($ID : Text; $message : Text; $value : Integer; $sharedForProgressBar : Object)
var $ProgressBarID : Integer
var $message2 : Text
$ProgressBarID:=$sharedForProgressBar.ID
If (($ProgressBarID=0) && ($value#100))
$ProgressBarID:=Progress New
Use ($sharedForProgressBar)
$sharedForProgressBar.ID:=$ProgressBarID
End use
Progress SET TITLE($ProgressBarID; $ID)
// check if we want stop, if yes, add stop button
If ($sharedForProgressBar.EnableButton#Null)
Progress SET BUTTON ENABLED($ProgressBarID; True)
End if
End if
If ($ProgressBarID#0)
If (Progress Stopped($ProgressBarID)) // only if stop button is enabled
Use ($sharedForProgressBar)
$sharedForProgressBar.Stop:=True
Use ($sharedForProgressBar.EnableButton)
$sharedForProgressBar.EnableButton.stop:=True
End use
End use
End if
Case of
: ($value=100)
Progress QUIT($ProgressBarID)
Use ($sharedForProgressBar)
$sharedForProgressBar.ID:=0
End use
: ($value<0)
$message2:=Replace string($message; " "; "") // ignore totally empty messages, happens with gdrive
If ($message2#"")
Progress SET MESSAGE($ProgressBarID; $message)
End if
Else
Progress SET PROGRESS($ProgressBarID; $value/100)
Progress SET MESSAGE($ProgressBarID; $message)
End case
End if
⇧
[class]EnvironnementALV - 30/05/2025 18:04:12
property XML : cs.XML
property typeApplication4D : Integer
property Applications : Collection
Class constructor()
var $RacineXML; $ElémentXML; $nomLong; $nomCourt : Text
var $i; $type; $icone : Integer
This.typeApplication4D:=Application type
This.XML:=cs.XML.me
// lister les types d'application gérées
This.Applications:=New collection
$RacineXML:=DOM Parse XML source(Get 4D folder(Current resources folder)+"DataSDK.xml")
// lister les applications gérées
ARRAY TEXT($Elements; 0)
$ElémentXML:=DOM Find XML element($RacineXML; "Applications/item"; $Elements)
For ($i; 1; Size of array($Elements))
Case of
: (Not(This.XML.LireLeChemin(->$Elements{$i}; "type"; ->$type).success))
: (Not(This.XML.LireLeChemin(->$Elements{$i}; "nomLong"; ->$nomLong).success))
: (Not(This.XML.LireLeChemin(->$Elements{$i}; "nomCourt"; ->$nomCourt).success))
: (Not(This.XML.LireLeChemin(->$Elements{$i}; "icone"; ->$icone).success))
End case
This.Applications.push(New object("type"; $type; "nomLong"; $nomLong; "nomCourt"; $nomCourt; "icone"; $icone))
End for
DOM CLOSE XML($RacineXML)
//--------------------
// MARK:environnement Application
//--------------------
Function typeApplication()->$result : Integer
// renvoyer l'un des types d'application ALV
// par défaut un type 4D
$result:=This.typeApplication4D
Case of
: ($result=4D Remote mode)
// 2 cas de client 4D : client du serveur HTTP ou du serveur APP
If (Is compiled mode(*))
$result:=ALV Client APP
Else
$result:=4D Remote mode
End if
// tester si l'application est le Serveur WEB
: ($result=4D Server)
If (Is compiled mode(*))
$result:=ALV Serveur APP
Else
$result:=ALV Serveur HTTP
End if
Else
$result:=ALV BDD mère
End case
Function estServeur()->$result : Boolean
var $type : Integer
$type:=This.typeApplication()
$result:=($type=ALV Serveur HTTP) | ($type=ALV Serveur APP)
Function estClient()->$result : Boolean
var $type : Integer
$type:=This.typeApplication()
$result:=($type=ALV Client APP) | ($type=4D Remote mode)
Function estExecuteDansAPP()->$result : Boolean
// => chercher si l'exécution est dans l'APP
// lire les ressources de la base hôte : le fichier "Commun.xml" doit exister
var $c : Collection
$c:=Folder(fk resources folder; *).files(fk ignore invisible)
$result:=($c.query("fullName = :1"; "Commun.xml").length=1)
Function infosApplication($typeDemandé : Integer)->$result : Object
// renvoyer les infos de l'application de type $typeDemandé
var $type : Integer
var $sélection : Collection
var $erreur : cs.Traces
If (Count parameters=0)
// prendre le type de l'application courante
$type:=This.typeApplication()
Else
$type:=$typeDemandé
End if
$sélection:=This.Applications.query("type = :1"; $type)
If ($sélection.length>0)
$result:=$sélection[0]
Else
// erreur sur le type
$result:=Null
$erreur:=cs.Traces.new().CréerErreur("SDK"; -15068; Current method name; "le type d'application "+String($type)+" n'est pas connu")
$erreur.ErrorLabel:=Localized string(String($erreur.Error))
$erreur.LeverException([msgk_event; msgk_instal])
End if
//--------------------
// MARK:environnement système
//--------------------
Function infosSystème()->$result : Object
// information sur l'environnement système du contexte
var $c1; $c2 : Collection
$result:=New object
// IP de la machine (remplacement de "IT_MyTCPAddr")
$c1:=System info.networkInterfaces
Case of
: ($c1.query("type = :1"; "ethernet").length>0)
// la machine est connectée au réseau par éthernet (au moins)
// on prend la première liaison
$c2:=$c1.query("type = :1"; "ethernet")
: ($c1.query("type = :1"; "wifi").length>0)
// la machine est connectée au réseau par éthernet (au moins)
$c2:=$c1.query("type = :1"; "wifi")
Else
$c2:=New collection
End case
// on prend la première liaison et l'adresse IPv4
If ($c2.length>0)
$result.IPadresse:=$c2[0].ipAddresses.query("type = :1"; "ipv4")[0].ip
End if
Function infoPlateForme()->$result : Object
$result:=New object
$result.ID:=1+Num(Is Windows)
$result.nom:=Choose(Is Windows; "WIN"; "OSX")
//--------------------
// MARK:Version APP
//--------------------
Function LireVersionAPP()->$result : Text
// renvoie au format texte la version courante vX.Y.Z de l'application ALV
If (This.typeApplication()=ALV BDD mère)
// en mode développement, utiliser le nom du dossier courant (format type "vX.Y.ZrNN")
// attention : comme il y a des "." dans le name , il faut utiliser .fullName
$result:=cs.$document.new().getStructureFolder().parent.fullName
Else
// ce champ n'existe qu'en serveur Web, serveur APP, application fusionnée :
cs.ResourceALV.me.SetVariable(Est Ressource Release; "Versionnage/Application/application_ALV"; Is text; ->$result)
End if
Function FixerIDversionAPP()->$result : Text
// transforme en numérique la version format texte du fichier application
// formater façon numérique F(ou B)XXYYZZ permettant le tri
// num($result) supprime F ou B => peut servir à trier les versions
var $version : Text
var $i; $j : Integer
$result:=This.LireVersionAPP()
// si r est présent => beta version (B), sinon version finale (F)
If (Position("r"; $result)>0)
// release
$version:="B"
// virer la release
$result:=Substring($result; 1; Position("r"; $result)-1)
Else
$version:="F"
End if
$result:=$result+".0.0" // au cas où Y ou Z manquent
$result:=Replace string($result; "v"; "")
// n° version
$i:=Num(Substring($result; 1; Position("."; $result)-1))
$result:=Substring($result; Position("."; $result)+1)
// n° sous version
$j:=Num(Substring($result; 1; Position("."; $result)-1))
$result:=Substring($result; Position("."; $result)+1)
// construire l'ID
$result:=$version+String($i; "00")+String($j; "00")+String(Num(Substring($result; 1; Position("."; $result)-1)); "00")
Function HorodaterBDD()->$result : Text
// *** les fichiers data sont versionnés par horodatage (ils seront stockés dans le dossier de la version courante du fichier de données)
// remarque : $result peut servir à trier les versions
$result:="BDD_"+This.getHorodage()
Function LireVersionBDD($chemin : Text)->$result : Text
// renvoie au format texte la version du fichier data $chemin
$result:=Replace string($chemin; "BDD_"; "")
// remettre au format ISO
$result:=Change string($result; ":"; Position("-"; $result; Position("_"; $result)))
$result:=Change string($result; ":"; Position("-"; $result; Position("_"; $result)))
$result:=Replace string($result; "_"; "T")
$result:=$result+"Z"
Function getHorodage()->$result : Text
var $dataTexte : Text
// date et heure du jour, permettant le tri
// rappel : la date ISO est planétaire! (pas forcément l'heure locale)
$dataTexte:=String(Current date; ISO date GMT; Current time)
// il faut un nom compatible du gestionnaire de fichier et du FTP
$dataTexte:=Replace string($dataTexte; "T"; "_")
$dataTexte:=Replace string($dataTexte; ":"; "-"; 1)
$dataTexte:=Replace string($dataTexte; ":"; "-"; 1)
$dataTexte:=Replace string($dataTexte; "Z"; "")
$result:=$dataTexte
//--------------------
// MARK:Fichiers de version
//--------------------
Function CréerFichierReleaseAPP()
var $chemin : 4D.File
var $dataTexte; $structureDeDonnées : Text
var $date; $dateModif : Date
var $heure; $heureModification : Time
var $verrouillé; $invisible : Boolean
// attention "resources" de l'application, un seul "s"
$chemin:=cs.$document.new().getStructureFolder().folder("Resources").file("Releases.xml")
// écrire les données de version dans le fichier $chemin
// lire le fichier ressources
If (Not(This.XML.LireFichier($chemin; ->$structureDeDonnées).success))
// initialiser le fichier
This.XML.CréerArbre(->$structureDeDonnées; "Ainsi_La_Vie")
//XML Ecrire le chemin(->$structureDeDonnées; "Ainsi_La_Vie")
End if
// version de l'application ALV
$dataTexte:=This.LireVersionAPP()
This.XML.EcrireLeChemin(->$structureDeDonnées; "Versionnage/Application/application_ALV"; ->$dataTexte)
// la date
GET DOCUMENT PROPERTIES(Structure file; $verrouillé; $invisible; $date; $heure; $dateModif; $heureModification)
This.XML.EcrireLeChemin(->$structureDeDonnées; "Versionnage/Application/date"; ->$dateModif)
This.XML.EcrireLeChemin(->$structureDeDonnées; "Versionnage/Application/heure"; ->$heureModification)
// écrire la version courante 4D
$dataTexte:=Application version(*) // version de l'application 4D, format : "F001xx0y" xx = version 4D, y = n° révision "bugFix" (RELEASE non achetée -> pas gérée)
This.XML.EcrireLeChemin(->$structureDeDonnées; "Versionnage/Application/application_4d"; ->$dataTexte)
// rappel : la version du fichier de données est écrite par ailleurs
// enregistrer dans le fichier
$dataTexte:=DOM Parse XML variable($structureDeDonnées)
DOM EXPORT TO FILE($dataTexte; $chemin.platformPath) // génère une erreur
DOM CLOSE XML($dataTexte)
Function VersionnerBDD()
// écrire les données de version aux ressources de l'application fusionnée locale ou du serveur Web
var $dataTexte : Text
var $date : Date
var $heure : Time
// obtenir l'horodatage des données par le nom du dossier du fichier de données (c'est le plus sûr)
//$dataTexte:=Documents systeme("GetFolderName"; Data file)
//ALERT(Data file)
$dataTexte:=Folder(Data file; fk platform path).parent.name
$dataTexte:=This.LireVersionBDD($dataTexte)
// lire date et heure
$date:=Date($dataTexte)
$heure:=Time($dataTexte)
cs.ResourceALV.me.SetResourceALV(Est Ressource APP; "Versionnage/Data/date"; ->$date)
cs.ResourceALV.me.SetResourceALV(Est Ressource APP; "Versionnage/Data/heure"; ->$heure)
⇧
[class]XML - 23/02/2026 19:37:47
property trace : cs.Traces
property attributs : Object
property typeData : Integer
singleton Class constructor()
This.trace:=cs.Traces.new()
This.trace.CréerErreur("SDK"; 0; Current method name; "")
Function LireFichier($fichier : 4D.File; $ptrArbre : Pointer)->$result : Object
var $RacineXML : Text
$ptrArbre->:=""
Case of
: (Not($fichier.exists))
This.trace.Error:=-15000
This.trace.ErrorDescription:="$1 n'est pas un objet fichier"
: (Type($ptrArbre->)#Is text)
This.trace.Error:=-15068
This.trace.ErrorDescription:="$2 n'est pas un pointeur texte"
Else
$RacineXML:=DOM Parse XML source($fichier.platformPath)
If (ok=1)
DOM EXPORT TO VAR($RacineXML; $ptrArbre->)
DOM CLOSE XML($RacineXML)
Else
This.trace.Error:=-15075
This.trace.ErrorDescription:="Fichier "+$fichier.platformPath
End if
End case
This.trace.ErrorLabel:=Localized string(String(This.trace.Error))
This.trace.FixerSuccess()
This.trace.LeverException([msgk_event; msgk_log])
$result:=OB Copy(This.trace)
Function CréerArbre($ptrItem : Pointer; $racine : Text)->$result : Object
// initialiser dans $ptrItem une structure XLM de nom $racine
var $xPath; $RacineXML : Text
// fixer le nameSpace
cs.ResourceALV.me.SetVariable(Est Ressource APP; "Ressources_Communes/Name_Space"; Is text; ->$xPath)
// créer la structure
$RacineXML:=DOM Create XML Ref($racine; $xPath)
DOM SET XML DECLARATION($RacineXML; "utf-8"; False)
Case of
: (Not(Is a variable($ptrItem)))
This.trace.Error:=-15068
This.trace.ErrorDescription:="$1 n'est pas une variable"
: (Type($ptrItem->)=Is text)
// on a une variable texte
DOM EXPORT TO VAR($RacineXML; $ptrItem->)
This.trace.Error:=-15074*Num(ok=0)
This.trace.ErrorDescription:="Export impossible dans la variable texte $2"
: (Type($ptrItem->)=Is object)
// on a un chemin de fichier (peut ne pas exister)
If ($ptrItem->exists)
DELETE DOCUMENT($ptrItem->platformPath)
End if
DOM EXPORT TO FILE($RacineXML; $ptrItem->platformPath) //génère une erreur
This.trace.Error:=-15073*Num(ok=0)
This.trace.ErrorDescription:="Export impossible dans la variable objet $2"
Else
This.trace.Error:=-15068
This.trace.ErrorDescription:="$1 n'est pas une variable texte ou 4D.File"
End case
This.trace.ErrorLabel:=Localized string(String(This.trace.Error))
This.trace.FixerSuccess()
This.trace.LeverException([msgk_event; msgk_log])
$result:=OB Copy(This.trace)
//--------------------
//MARK:Dessin SVG
//--------------------
Function CréerArbreSVG($largeur : Integer; $hauteur : Integer; $titre : Text; $description : Text; $boxAuto : Boolean; $format : Integer)->$result : Text
var $nbreParams : Integer
$nbreParams:=Count parameters
If ($nbreParams<6)
$format:=Truncated non centered
If ($nbreParams<5)
$boxAuto:=True
If ($nbreParams<4)
$description:=""
If ($nbreParams<3)
$titre:=""
End if
End if
End if
End if
$result:=DOM Create XML Ref("svg"; "http://www.w3.org/2000/svg"; "xmlns:xlink"; "http://www.w3.org/1999/xlink")
DOM SET XML DECLARATION($result; "UTF-8"; False)
DOM SET XML ATTRIBUTE($result; "preserveAspectRatio"; "none"; "version"; "1.1"; "width"; $largeur; "height"; $hauteur)
If ($boxAuto)
// viewBox a les dimensions du document
DOM SET XML ATTRIBUTE($result; "viewBox"; "0 0 "+String($largeur)+" "+String($hauteur))
Else
DOM SET XML ATTRIBUTE($result; "viewBox"; "0 0 0 0")
End if
Function AjouterTexte($racineXML : Text; $x : Real; $y : Real; $texte : Text; $taillePolice : Integer; $couleurPP : Text; $couleurAP : Text)->$result : Text
var $nbreParams : Integer
$nbreParams:=Count parameters
If ($nbreParams<7)
$couleurAP:=Choose(Get Application color scheme="light"; "white"; "black")
If ($nbreParams<6)
$couleurPP:=Choose(Get Application color scheme="light"; "black"; "white")
If ($nbreParams<5)
$taillePolice:=14
End if
End if
End if
// cf W3C SVG1.0 : le système de coordonnées initial de la zone de visualisation (et par là-même le système de coordonnées utilisateur initial)
// a pour origine le coin supérieur gauche de la zone de visualisation, le sens positif de l'axe-x étant vers la droite,
// le sens positif de l'axe-y vers le bas et le texte rendu ayant une orientation « verticale »
// , ce qui signifie que les glyphes sont orientés de telle manière que les caractères romans et ceux idéographiques en pleine taille des écritures asiatiques
// ont le bord haut de leurs glyphes correspondants orientés vers le haut et le bord droit de leurs glyphes correspondants orientés vers la droite
// (qu'on se le dise!)
$result:=DOM Create XML element($racineXML; "text"; "x"; $x; "y"; $y)
If (OK=1)
DOM SET XML ELEMENT VALUE($result; $texte)
DOM SET XML ATTRIBUTE($result; "stroke"; $couleurPP; "fill"; $couleurAP; "font-size"; $taillePolice)
Else
$result:=""
End if
Function AjouterRectangle($racineXLM : Text; $x : Real; $y : Real; $largeur : Integer; $hauteur : Integer; $xArrondi : Integer; $yArrondi : Integer; $couleurPP : Text; $couleurAP : Text; $épaisseurTrait : Real)->$result : Text
var $nbreParams : Integer
$nbreParams:=Count parameters
If ($nbreParams<10)
$épaisseurTrait:=3
If ($nbreParams<9)
$couleurAP:=Choose(Get Application color scheme="light"; "white"; "black")
If ($nbreParams<8)
$couleurPP:=Choose(Get Application color scheme="light"; "black"; "white")
If ($nbreParams<6)
$xArrondi:=0
$yArrondi:=0
End if
End if
End if
End if
$result:=DOM Create XML element($racineXLM; "rect"; "x"; $x; "y"; $y; "width"; $largeur; "height"; $hauteur)
If (OK=1)
DOM SET XML ATTRIBUTE($result; "rx"; $xArrondi; "ry"; $yArrondi; "stroke"; $couleurPP; "fill"; $couleurAP; "stroke-width"; String($épaisseurTrait; "&xml"))
Else
$result:=""
End if
Function AjouterImage($racineXLM : Text; $path : Text; $x : Real; $y : Real; $largeur : Integer; $hauteur : Integer)->$result : Text
var $nbreParams : Integer
var $image : Picture
$nbreParams:=Count parameters
If ($nbreParams<5)
$largeur:=0
$hauteur:=0
READ PICTURE FILE($path; $image)
If (ok=1)
PICTURE PROPERTIES($image; $largeur; $hauteur)
End if
If ($nbreParams<3)
$x:=0
$y:=0
End if
End if
If (($largeur>0) & ($hauteur>0) & (Test path name($path)=Is a document))
$path:="file:///"+cs.Outils.me.ConvertirPathVersURL($path; False; True)
$result:=DOM Create XML element($racineXLM; "image"; "xlink:href"; $path)
If (ok=1)
DOM SET XML ATTRIBUTE($result; "width"; $largeur; "height"; $hauteur; "x"; $x; "y"; $y)
End if
Else
$result:=""
End if
Function AjouterTransform($racineXML : Text; $commande : Text; $valeurs : Collection)
var $argumentsAjoutés; $arguments : Text
var $position : Integer
// formater les arguments
$argumentsAjoutés:=""
For ($position; 0; $valeurs.length-1)
$argumentsAjoutés:=$argumentsAjoutés+String($valeurs.at($position); "&xml")+","
End for
$argumentsAjoutés:=Substring($argumentsAjoutés; 1; Length($argumentsAjoutés)-1)
$argumentsAjoutés:="("+$argumentsAjoutés+")"
Try
DOM GET XML ATTRIBUTE BY NAME($racineXML; "transform"; $arguments) //ici erreur normale si aucune transformation n'est encore définie
Catch
$arguments:=""
End try
If (Length($arguments)>0)
// ajouter à la transformation existante
$Position:=Position($commande; $arguments; *)
If ($Position>0)
// la commande existe : remplacer les paramètres
$Position:=Position(Char(40); $arguments; $position; *) // remplacer "("
$commande:=Substring($arguments; $Position; Position(Char(41); $arguments; $position; *)-$position+1)
$arguments:=Replace string($arguments; $commande; $argumentsAjoutés; *)
Else
//ajouter la commande
$arguments:=$arguments+" "+$commande+$argumentsAjoutés
End if
Else
//créer la transformation
$arguments:=$commande+$argumentsAjoutés
End if
DOM SET XML ATTRIBUTE($racineXML; "transform"; $arguments)
//--------------------
//MARK:Lecture XML
//--------------------
Function LireLeChemin($ptrItem : Pointer; $xPath : Text; $ptrVar : Pointer; $attributs : Object)->$result : cs.Traces
var $RacineXML : Text
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
This.attributs:=Null
If (Count parameters>3)
This.attributs:=$attributs
End if
// Rechercher le type de donnée
Case of
: (Not(Is a variable($ptrItem)))
$result.Error:=-15068
$result.ErrorDescription:="$ptrItem n'est pas une variable"
: (Type($ptrItem->)=Is object)
// on a un chemin de fichier
If ($ptrItem->exists)
$RacineXML:=DOM Parse XML source($ptrItem->platformPath)
$result:=This._LireVariable($RacineXML; $xPath; $ptrVar)
DOM CLOSE XML($RacineXML)
End if
: (Type($ptrItem->)#Is text)
// on n'a pas une variable texte
$result.Error:=-15075
$result.ErrorDescription:="$ptrItem n'est pas un objet ou un texte"
// on a une variable texte, 2 cas :
: ($ptrItem->="<?xml@")
// on a une structure XML
$RacineXML:=DOM Parse XML variable($ptrItem->)
$result:=This._LireVariable($RacineXML; $xPath; $ptrVar)
DOM CLOSE XML($RacineXML)
: ((Length($ptrItem->)=32) & (Match regex("[0-9ABCDEF]{32}"; $ptrItem->)))
// on a un élément DOM
$result:=This._LireVariable($ptrItem->; $xPath; $ptrVar)
Else
$result.Error:=-15068
$result.ErrorDescription:="$ptrItem n'est pas un objet, une structure XML ou un élément XML"
End case
$result.ErrorLabel:=Localized string(String($result.Error))
$result.FixerSuccess()
If (Not($result.success))
$result.EnvoyerMessages([msgk_event; msgk_log]; "SDK"; $result.ErrorLabel; $result.Source; $result.ErrorDescription)
End if
Function _LireVariable($RacineXML : Text; $xPath : Text; $ptrVar : Pointer)->$result : cs.Traces
// renvoie vrai si traité sans erreur
var $ElementXML; $attribut : Text
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
$ElementXML:=DOM Find XML element($RacineXML; $xPath)
$result.success:=(Ok=1)
// lire la donnée et la renvoyer
If ($result.success)
DOM GET XML ATTRIBUTE BY NAME($ElementXML; "Type"; $attribut)
$result.success:=(Ok=1)
This.typeData:=Num($attribut)
// lire la valeur XML (type Blob, Text, Integer ou tableau), résultat pointé par $ptrVar
Case of
: (Not($result.success))
$result.Error:=-15076
$result.ErrorDescription:="l'attribut 'Type' n'existe pas d'élément au chemin "+$xPath
: (Type($ptrVar->)#This.typeData)
$result.Error:=-15068
$result.ErrorDescription:="le type de la valeur lue dans $1 est différent du type de la variable $ptrData"
: (This._LireVariableScalaire($ElementXML; $ptrVar))
: (This._LireCollection($ElementXML; $xPath; $ptrVar))
: (This._LireBlob($ElementXML; $ptrVar))
: (This._LireTableauINT($ElementXML; $ptrVar))
: (This._LireTableauTEXTE($ElementXML; $ptrVar))
: (This._LireTableauOBJET($ElementXML; $ptrVar))
Else
$result.Error:=-15068
$result.ErrorDescription:="le type '"+$attribut+"' de l'élément XML ne correspond pas à celui de la variable"
End case
If ($result.Error=0)
This._LireAttributs($ElementXML)
End if
Else
$result.Error:=-15077
$result.ErrorDescription:="la structure XML n'a pas d'élément au chemin "+$xPath
End if
$result.FixerSuccess()
Function _LireVariableScalaire($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
// renvoie vrai si pas d'erreur
var $dataValeur : Text
var $typeVar : Integer
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
// renvoyer la valeur dans le type demandé
$typeVar:=Type($ptrData->)
// depuis v17 : ici type donne le bon type pour tout ce qui n'est pas un champ (ou une variable)
// en particulier les champs alpha renvoient ici un type 0, les champs entier, en interprété, renvoient ici un type numerique
// lire la donnée
DOM GET XML ELEMENT VALUE($RacineXML; $dataValeur)
// décoder et stocker la valeur
$result:=True
Case of
: (ok=0)
// erreur lecture de la valeur de la référence
$trace.Error:=-15076
$trace.ErrorDescription:="erreur de lecture de la donnée"
: (($typeVar=Is alpha field) | ($typeVar=Is text))
$ptrData->:=$dataValeur
: (($typeVar=Is real) | ($typeVar=Is integer) | ($typeVar=Is longint))
$ptrData->:=Num($dataValeur)
: ($typeVar=Is date)
$ptrData->:=Date($dataValeur)
: ($typeVar=Is time)
$ptrData->:=Time($dataValeur)
: ($typeVar=Is boolean)
$ptrData->:=($dataValeur="Vrai")
Else
// pas traitée ici
$result:=False
End case
$trace.ErrorLabel:=Localized string(String($trace.Error))
$trace.LeverException([msgk_event; msgk_log])
Function _LireCollection($RacineXML : Text; $xPath : Text; $ptrVar : Pointer)->$result : Boolean
// renvoie vrai si traité sans erreur
var $dataTexte; $cDATA : Text
var $c : Collection
$result:=(Type($ptrVar->)=Is collection)
If ($result)
// lire la cDATA
DOM GET XML ELEMENT VALUE($RacineXML; $dataTexte; $cDATA)
// décrocheter
$cDATA:=Replace string($cDATA; "[["; "[")
$cDATA:=Replace string($cDATA; "]]"; "]")
// collectionner
$c:=JSON Parse($cDATA; Is collection)
$ptrVar->:=$c
End if
Function _LireBlob($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $dataBlob : Blob
$result:=(This.typeData=Is BLOB)
If ($result)
DOM GET XML ELEMENT VALUE($RacineXML; $dataBlob)
$ptrData->:=$dataBlob
End if
Function _LireTableauTEXTE($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
$result:=(This.typeData=Text array)
If ($result)
This._LireTableau($RacineXML; $ptrData)
End if
Function _LireTableauINT($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
// remplir un tableau texte puis convertir en INT
var $i : Integer
$result:=(This.typeData=LongInt array)
Case of
: (Not($result))
: (Not(Type($ptrData->)=LongInt array))
Else
ARRAY TEXT($tabTexte; 0)
This._LireTableau($RacineXML; ->$tabTexte)
//%W-518.5
ARRAY LONGINT($ptrData->; Size of array($tabTexte))
//%W+518.5
If (Size of array($tabTexte)>0)
For ($i; 1; Size of array($tabTexte))
$ptrData->{$i}:=Num($tabTexte{$i})
End for
End if
End case
Function _LireTableau($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $ElementXML; $dataNom; $dataValeur : Text
var $i : Integer
// relire $RacineXML, chaque élément du tableau a pour nom "Element"
// ici on remplit un tableau texte
If (Type($ptrData->)=Text array)
$ElementXML:=DOM Get first child XML element($RacineXML; $dataNom; $dataValeur)
If (ok=1)
// tableau non vide
//%W-518.5
ARRAY TEXT($ptrData->; DOM Count XML elements($RacineXML; "Element"))
//%W+518.5
Repeat
If ($dataNom="Element")
DOM GET XML ATTRIBUTE BY NAME($ElémentXML; "n"; $dataNom)
$i:=Num($dataNom) // rang de l'élément dans le tableau
If ($i<=Size of array($ptrData->)) //au cas où erreur dans les indices du tableau
$ptrData->{$i}:=$dataValeur
End if
End if
$ElémentXML:=DOM Get next sibling XML element($ElémentXML; $dataNom; $dataValeur)
Until (ok=0) //fin de liste, ou erreur de lecture
Else
//renvoyer un tableau vide
//%W-518.5
ARRAY TEXT($ptrData->; 0)
//%W+518.5
End if
Else
// quoi faire?
End if
Function _LireTableauOBJET($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $ElementXML; $EnfantXML; $dataNom; $dataValeur; $attribut : Text
var $typeVar : Integer
var $data : Object
$result:=(This.typeData=Object array)
Case of
: (Not($result))
: (Not(Type($ptrData->)=Object array))
Else
// relire $RacineXML, chaque élément du tableau a pour nom "Element" (nom interne)
//%W-518.5
ARRAY OBJECT($ptrData->; 0)
//%W+518.5
$ElémentXML:=DOM Get first child XML element($RacineXML; $dataNom; $dataValeur)
Repeat
$data:=New object()
// reconstituer l'objet, avec des variables typées
$EnfantXML:=DOM Get first child XML element($ElémentXML; $dataNom; $dataValeur)
Repeat
DOM GET XML ATTRIBUTE BY NAME($EnfantXML; "Type"; $attribut)
$typeVar:=Num($attribut)
Case of
: (($typeVar=Is text) | ($typeVar=Is date))
OB SET($data; $dataNom; $dataValeur)
: ($typeVar=Is longint)
OB SET($data; $dataNom; Num($dataValeur))
: ($typeVar=Is boolean)
OB SET($data; $dataNom; ($dataValeur="Vrai"))
End case
$EnfantXML:=DOM Get next sibling XML element($EnfantXML; $dataNom; $dataValeur)
Until (ok=0) //fin de liste, ou erreur de lecture
APPEND TO ARRAY($ptrData->; $data)
$ElémentXML:=DOM Get next sibling XML element($ElémentXML; $dataNom; $dataValeur)
Until (ok=0) //fin de liste, ou erreur de lecture
End case
Function _LireAttributs($racineXML : Text)
var $nbreAttributs; $i : Integer
var $propriété; $valeur : Text
$nbreAttributs:=DOM Count XML attributes($racineXML)
Case of
: (This.attributs=Null)
: ($nbreAttributs=0)
Else
For ($i; 1; $nbreAttributs)
DOM GET XML ATTRIBUTE BY INDEX($RacineXML; $i; $propriété; $valeur)
This.attributs[$propriété]:=$valeur
End for
End case
//--------------------
//MARK:Ecriture XML
//--------------------
Function EcrireLeChemin($ptrItem : Pointer; $xPath : Text; $ptrData : Pointer; $attributs : Object)->$result : cs.Traces
var $RacineXML : Text
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
This.attributs:=Null
If (Count parameters>3)
This.attributs:=$attributs
End if
// Rechercher le type de donnée
Case of
: (Not(Is a variable($ptrItem)))
$result.Error:=-15068
$result.ErrorDescription:="$ptrItem n'est pas une variable"
: (Type($ptrItem->)=Is object)
// on a un chemin de fichier
If ($ptrItem->exists)
$RacineXML:=DOM Parse XML source($ptrItem->platformPath)
This._EcrireLeChemin($RacineXML; $xPath; $ptrData)
DOM EXPORT TO FILE($RacineXML; $ptrItem->platformPath)
DOM CLOSE XML($RacineXML)
Else
// créer une structure XML
$RacineXML:=DOM Create XML Ref($xPath)
DOM EXPORT TO FILE($RacineXML; $ptrItem->platformPath)
DOM CLOSE XML($RacineXML)
End if
: (Type($ptrItem->)#Is text)
// on a une variable texte, 2 cas :
$result.Error:=-15068
$result.ErrorDescription:="$ptrItem n'est pas un objet ou un texte"
: ($ptrItem->="<?xml@")
// on a une structure XML
$RacineXML:=DOM Parse XML variable($ptrItem->)
$result:=This._EcrireLeChemin($RacineXML; $xPath; $ptrData)
DOM EXPORT TO VAR($RacineXML; $ptrItem->)
DOM CLOSE XML($RacineXML)
: ((Length($ptrItem->)=32) & (Match regex("[0-9ABCDEF]{32}"; $ptrItem->)))
// on a un élément DOM
$result:=This._EcrireLeChemin($ptrItem->; $xPath; $ptrData)
Else
$result.Error:=-15068
$result.ErrorDescription:="$ptrItem n'est pas un objet, une structure XML ou un élément XML"
End case
$result.ErrorLabel:=Localized string(String($result.Error))
$result.FixerSuccess()
$result.LeverException([msgk_event; msgk_log])
Function _EcrireLeChemin($RacineXML : Text; $xPath : Text; $ptrVar : Pointer)->$result : cs.Traces
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
Case of
: (This._EcrireObjet($RacineXML; $xPath; $ptrVar))
: (This._EcrireVariable($RacineXML; $xPath; $ptrVar))
Else
$result.Error:=-15068
$result.ErrorDescription:="le chemin xPath '"+$xPath+"' n'existe pas dans la structure XML"
End case
$result.FixerSuccess()
Function _EcrireObjet($RacineXML : Text; $xPath : Text; $ptrVar : Pointer)->$result : Boolean
// renvoie vrai si traité sans erreur
var $dataTexte : Text
$result:=(Type($ptrVar->)=Is object)
If ($result)
// pour l'instant un seul cas : objet sélection entités
// écrire le nom de la dataClass
$dataTexte:=$ptrVar->getDataClass().getInfo().name
This._EcrireLeChemin($RacineXML; $xPath+"/DataClassNom"; ->$dataTexte)
// collecter les entités ID
$dataTexte:=JSON Stringify($ptrVar->toCollection().extract("ID"))
// ajouter les entités
This._EcrireLeChemin($RacineXML; $xPath+"/Selection"; ->$dataTexte)
// le Numero Dans la sélection n'existe pas ici
End if
Function _EcrireVariable($RacineXML : Text; $xPath : Text; $ptrVar : Pointer)->$result : Boolean
// renvoie vrai si traité sans erreur
var $ElementXML : Text
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
$ElementXML:=DOM Find XML element($RacineXML; $xPath)
If (Ok=1)
DOM REMOVE XML ELEMENT($ElementXML)
End if
$ElementXML:=DOM Create XML element($RacineXML; $Xpath; "Type"; String(Type($ptrVar->)))
$result:=(Ok=1)
// écrire la donnée
If ($result)
// écrire la valeur XML (type Blob, Text, Integer ou tableau)
Case of
: (This._EcrireTableauINT($ElementXML; $ptrVar))
: (This._EcrireTableauTEXTE($ElementXML; $ptrVar))
: (This._EcrireTableauOBJET($ElementXML; $ptrVar))
: (This._EcrireVariableScalaire($ElementXML; $ptrVar))
: (This._EcrireCollection($ElementXML; $ptrVar))
Else
$trace.Error:=-15068
$trace.ErrorDescription:="le type '"+String(Type($ptrVar->))+"' de l'élément XML ne correspond pas à celui de la variable"
End case
This._EcrireAttributs($ElementXML)
Else
$trace.Error:=-15077
$trace.ErrorDescription:="la structure XML n'a pas d'élément au chemin "+$xPath
End if
$trace.ErrorLabel:=Localized string(String($trace.Error))
$trace.FixerSuccess()
$trace.LeverException([msgk_event; msgk_log])
$result:=$trace.success
Function _EcrireVariableScalaire($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
// renvoie vrai si pas d'erreur
var $typeVar : Integer
// ecrire la valeur dans le type demandé
$typeVar:=Type($ptrData->)
// endécoder et stocker la valeur
$result:=True
Case of
: (($typeVar=Is alpha field) | ($typeVar=Is text))
DOM SET XML ELEMENT VALUE($RacineXML; $ptrData->)
: ($typeVar=Is BLOB)
// encodage automatique en base64
DOM SET XML ELEMENT VALUE($RacineXML; $ptrData->)
: (($typeVar=Is real) | ($typeVar=Is integer) | ($typeVar=Is longint))
DOM SET XML ELEMENT VALUE($RacineXML; Num($ptrData->))
: ($typeVar=Is date)
DOM SET XML ELEMENT VALUE($RacineXML; String($ptrData->; ISO date GMT))
: ($typeVar=Is time)
DOM SET XML ELEMENT VALUE($RacineXML; String($ptrData->))
: ($typeVar=Is boolean)
DOM SET XML ELEMENT VALUE($RacineXML; String(Num($ptrData->); "Vrai;;Faux"))
Else
$result:=False
End case
Function _EcrireCollection($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $cDATA : Text
$result:=(Type($ptrData->)=Is collection)
If ($result)
$cDATA:="["+JSON Stringify($ptrData->)+"]"
DOM SET XML ELEMENT VALUE($RacineXML; $cDATA; *)
End if
Function _EcrireTableauTEXTE($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $ElementXML; $EnfantXML : Text
var $i : Integer
$result:=(Type($ptrData->)=Text array)
If ($result)
// é $RacineXML, chaque élément du tableau a pour nom "Element"
If (Size of array($ptrData->)>0)
For ($i; 1; Size of array($ptrData->))
$ElementXML:=DOM Create XML element($RacineXML; "Element"; "n"; String($i))
DOM SET XML ELEMENT VALUE($ElementXML; $ptrData->{$i})
End for
End if
// ajout de la taille du tableau
$ElementXML:=DOM Get parent XML element($RacineXML)
$EnfantXML:=DOM Create XML element($ElementXML; "NbreElements"; "Type"; String(Is longint))
DOM SET XML ELEMENT VALUE($EnfantXML; Size of array($ptrData->))
End if
Function _EcrireTableauINT($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
// remplir un tableau texte puis écrire
var $i : Integer
$result:=(Type($ptrData->)=LongInt array)
If ($result)
ARRAY TEXT($tabTexte; Size of array($ptrData->))
If (Size of array($ptrData->)>0)
For ($i; 1; Size of array($ptrData->))
$tabTexte{$i}:=String($ptrData->{$i})
End for
End if
This._EcrireTableauTEXTE($RacineXML; ->$tabTexte)
End if
Function _EcrireTableauOBJET($RacineXML : Text; $ptrData : Pointer)->$result : Boolean
var $ElementXML; $ElementEnfantXML : Text
var $i; $j; $typeVar : Integer
var $data : Object
$result:=(Type($ptrData->)=Object array)
If ($result)
// écrire dans $RacineXML chaque élément du tableau ; il a pour nom "Element" (nom interne)
If (Size of array($ptrData->)>0)
For ($i; 1; Size of array($ptrData->))
$data:=$ptrData->{$i}
// élément où écrire l'objet :
$ElementXML:=DOM Create XML element($RacineXML; "Element"; "n"; String($i))
// lire le contenu
ARRAY TEXT($attributs; 0)
ARRAY LONGINT($types; 0)
OB GET PROPERTY NAMES($data; $attributs; $types)
// écrire chaque élément (typé) de l'objet
For ($j; 1; Size of array($types))
$typeVar:=$types{$j}
$ElementEnfantXML:=DOM Create XML element($ElementXML; $attributs{$j}; "Type"; String($typeVar))
// on pourrait passer par ._EcrireVariableScalaire() avec l'utilisation de variables process. Pour faire simple on ecrit directement en fonction du type
Case of
: (($typeVar=Is text) | ($typeVar=Is date))
DOM SET XML ELEMENT VALUE($ElementEnfantXML; $data[$attributs{$j}])
: ($typeVar=Is longint)
DOM SET XML ELEMENT VALUE($ElementEnfantXML; String($data[$attributs{$j}]))
: ($typeVar=Is boolean)
DOM SET XML ELEMENT VALUE($ElementEnfantXML; String(Num($data[$attributs{$j}]); "Vrai;;Faux"))
Else
$result:=False
End case
End for
End for
End if
End if
Function _EcrireAttributs($racineXML : Text)
// Ecrire les attributs de $racineXML
var $propriété : Text
Case of
: (This.attributs=Null)
: (OB Is empty(This.attributs))
Else
For each ($propriété; OB Keys(This.attributs))
DOM SET XML ATTRIBUTE($racineXML; $propriété; This.attributs[$propriété])
End for each
End case
⇧
[class]Tache - 19/05/2026 16:25:33
property nomTache; nomProcess; nomProcessTache : Text
property numProcessTache; numProcessAppelant : Integer
property Tuer : Object
// progression
property Etat : Text
property State : Integer
property Time : Integer
property Avancement : Real
property debut : Integer
property duree : Integer
Class constructor()
Function Initialiser($params : Object)
Use (This)
This.nomTache:=$params.nomTache
This.nomProcess:=$params.nomProcess
This.numProcessAppelant:=$params.numProcessAppelant
This.Etat:=""
This.State:=0
This.Time:=0
This.Avancement:=-1
This.debut:=-1
This.duree:=-1
This.Tuer:=New signal(This.nomTache)
// pour debug
This.nomProcessTache:=Current process name
This.numProcessTache:=Current process
End use
//----------------------
//MARK:Attributs
//----------------------
Function FixerEtat($valeur : Text)
Use (This)
This.Etat:=$valeur
End use
Function FixerState($valeur : Integer)
Use (This)
This.State:=$valeur
End use
Function FixerTime($valeur : Integer)
Use (This)
This.Time:=$valeur
End use
Function FixerAvancement($valeur : Real)
Use (This)
This.Avancement:=$valeur
End use
Function FixerParamsAvancement($début : Integer; $durée : Integer)
Use (This)
This.debut:=$début
This.duree:=$durée
End use
//----------------------
//MARK:Fonctions
//----------------------
Function DésInscrire()
cs.RegistreTaches.me.DésInscrire(This.nomTache)
⇧
[class]ResourceALV - 30/05/2025 17:57:40
property rsrID; nomAttribut : Text
singleton Class constructor()
//--------------------
//MARK:Lecture
//--------------------
Function SetVariable($rsrID : Integer; $xPath : Text; $typeValeur : Integer; $ptrVal : Pointer)->$result : Boolean
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
This.rsrID:=String($rsrID)
This.nomAttribut:=This._AttribuerXpath($xPath)
Case of
: (Is nil pointer($ptrVal))
$trace.Error:=-16003
$trace.ErrorDescription:="$ptrVal est un pointeur nul"
: (This._LireResourceStore($typeValeur; $ptrVal))
// ok valeur renvoyée
: (Not(This._estResourceFichierInscrite()))
// pb d'installation
$trace.Error:=-16003
$trace.ErrorDescription:="ressource ID = "+This.rsrID
Else
$trace:=This._LireResourceFichier($xPath; $ptrVal)
If ($trace.success)
// mémoriser pour la prochaine fois
This._StorerResourceALV($ptrVal)
End if
End case
$trace.ErrorLabel:=Localized string(String($trace.Error))
$trace.FixerSuccess()
$trace.LeverException([msgk_event; msgk_log])
$result:=$trace.success
Function SetObjet($rsrID : Integer; $xPath : Text; $typeValeur : Integer; $data : Object; $nomAttribut : Text)->$result : Boolean
var $ptrVal : Pointer
var $texte : Text
var $integer : Integer
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
Case of
: ($typeValeur=Is text)
$ptrVal:=->$texte
: ($typeValeur=Is longint) // Is integer ou short long (2 octets) est legacy
$ptrVal:=->$integer
Else
$trace:=cs.Traces.new().CréerErreur("SDK"; -16003; Current method name; "type de valeur "+String($typeValeur)+" non traité")
End case
If ($trace.Error=0)
$result:=This.SetVariable($rsrID; $xPath; $typeValeur; $ptrVal)
// ResourceALVversVariable a géré l'erreur
If ($result)
$data[$nomAttribut]:=$ptrVal->
End if
End if
$trace.ErrorLabel:=Localized string(String($trace.Error))
$trace.FixerSuccess()
$trace.LeverException([msgk_event; msgk_log])
$result:=$trace.success
Function _LireResourceStore($typeValeur : Integer; $ptrVal : Pointer)->$result : Boolean
$result:=False
Case of
: (Not(OB Is defined(Storage; "RessourcesALV")))
: (Not(OB Is defined(Storage.RessourcesALV; This.rsrID)))
: (Not(OB Is defined(Storage.RessourcesALV[This.rsrID]; This.nomAttribut)))
Else
$result:=True
If ($typeValeur=Object array)
JSON PARSE ARRAY(OB Get(Storage.RessourcesALV[This.rsrID]; This.nomAttribut; Is text); $ptrVal->)
Else
$ptrVal->:=OB Get(Storage.RessourcesALV[This.rsrID]; This.nomAttribut; $typeValeur)
End if
End case
Function _LireResourceFichier($xPath : Text; $ptrVal : Pointer)->$result : cs.Traces
var $fichier : 4D.File
$result:=This._AccèsRessourceValide()
If ($result.success)
$fichier:=File(Storage.ResourcesInscrites[This.rsrID].chemin; fk platform path)
$result:=cs.XML.me.LireLeChemin(->$fichier; $xPath; $ptrVal)
End if
Function _StorerResourceALV($ptrVal : Pointer)
// mémoriser pour la prochaine fois
If (Not(OB Is defined(Storage; "RessourcesALV")))
Use (Storage)
Storage.RessourcesALV:=New shared object
End use
End if
If (Not(OB Is defined(Storage.RessourcesALV; This.rsrID)))
Use (Storage.RessourcesALV)
Storage.RessourcesALV[This.rsrID]:=New shared object
End use
End if
Use (Storage.RessourcesALV[This.rsrID])
If (Type($ptrVal->)=Object array)
OB SET(Storage.RessourcesALV[This.rsrID]; This.nomAttribut; JSON Stringify array($ptrVal->))
Else
OB SET(Storage.RessourcesALV[This.rsrID]; This.nomAttribut; $ptrVal->)
End if
End use
//--------------------
//MARK:Ecriture
//--------------------
Function SetResourceALV($rsrID : Integer; $xPath : Text; $ptrVal : Pointer)->$result : Boolean
var $trace : cs.Traces
$trace:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
This.rsrID:=String($rsrID)
This.nomAttribut:=This._AttribuerXpath($xPath)
Case of
: (Is nil pointer($ptrVal))
$trace.Error:=-16003
$trace.ErrorDescription:="$ptrVal est un pointeur nul"
: (Not(This._estResourceFichierInscrite()))
// pb d'installation
$trace.Error:=-16003
$trace.ErrorDescription:="ressource ID = "+This.rsrID
Else
$trace:=This._EcrireResourceFichier($xPath; $ptrVal)
End case
// c'est fait, il faut purger storage
If ($trace.success)
If (OB Is defined(Storage.RessourcesALV[This.rsrID]; This.nomAttribut))
Use (Storage.RessourcesALV[This.rsrID])
OB REMOVE(Storage.RessourcesALV[This.rsrID]; This.nomAttribut)
End use
End if
End if
$result:=$trace.success
Function _EcrireResourceFichier($xPath : Text; $ptrVal : Pointer)->$result : cs.Traces
var $fichier : 4D.File
$result:=This._AccèsRessourceValide()
If ($result.success)
$fichier:=File(Storage.ResourcesInscrites[This.rsrID].chemin; fk platform path)
$result:=cs.XML.me.EcrireLeChemin(->$fichier; $xPath; $ptrVal)
End if
Function _AccèsRessourceValide()->$result : cs.Traces
$result:=cs.Traces.new().CréerErreur("SDK"; -16003; Current method name; "")
Case of
: (Not(OB Is defined(Storage; "ResourcesInscrites")))
$result.ErrorDescription:="'ResourcesInscrites' non defini dans Storage"
: (Not(OB Is defined(Storage.ResourcesInscrites; This.rsrID)))
$result.ErrorDescription:="'"+This.rsrID+"' non defini dans Storage.ResourcesInscrites"
: (Not(OB Is defined(Storage.ResourcesInscrites[This.rsrID]; "chemin")))
$result.ErrorDescription:="'chemin' non defini dans Storage.ResourcesInscrites."+This.rsrID
Else
$result.Error:=0
End case
$result.FixerSuccess()
//--------------------
//MARK:Utilitaires
//--------------------
Function get ResourcesInscrites()->$result : Object
// renvoyer la liste de toutes les ressources ALV inscrites (par APP et composants)
$result:=New object
Case of
: (Not(OB Is defined(Storage; "ResourcesInscrites")))
: (Storage.ResourcesInscrites=Null)
Else
$result:=OB Copy(Storage.ResourcesInscrites)
End case
Function get RessourcesALV()->$result : Object
// renvoyer la liste de toutes les ressources ALV en storage
$result:=New object
Case of
: (Not(OB Is defined(Storage; "RessourcesALV")))
: (Storage.RessourcesALV=Null)
Else
$result:=OB Copy(Storage.RessourcesALV)
End case
Function Inscrire($rsrID : Integer; $data : Object)
var $inscription; $SharedData : Object
If (Not(OB Is defined(Storage; "ResourcesInscrites")))
Use (Storage)
// rappel : il y a un Storage par composant, application
Storage.ResourcesInscrites:=New shared object
End use
End if
// inscrire (voire re-inscrire si nouvel appel)
$SharedData:=OB Copy($data; ck shared)
$inscription:=Storage.ResourcesInscrites
Use ($inscription)
$inscription[String($rsrID)]:=$SharedData
End use
Function _estResourceFichierInscrite()->$result : Boolean
// renvoie vrai si la ressource .rsrID ont été enregistrées
$result:=OB Is defined(Storage; "ResourcesInscrites")
If ($result)
$result:=OB Is defined(Storage.ResourcesInscrites; This.rsrID)
End if
Function _AttribuerXpath($xPath : Text)->$result : Text
// transformer un chemin XML en un nom d'attribut d'objet
$result:=Replace string($xPath; "/"; "-")
$result:="RSR_"+$result
⇧
[class]$SystemWorkerProperties - 30/08/2023 09:39:00
property type; encoding; dataType; callbackID; _return : Text
property hideWindow : Boolean
property callback : 4D.Function
property data; stopbutton; SharedForProgressBar : Object
Class constructor($type : Text; $data : Object; $callback : 4D.Function; $callbackID : Text; $stopButton : Object)
This.type:=$type
This.encoding:="UTF-8"
This.dataType:="text"
This.hideWindow:=True
This.data:=$data
If (Count parameters>2)
This.callback:=$callback
This.callbackID:=$callbackID
This.stopbutton:=$stopButton
ASSERT(Value type($callback)=Is object; "Callback must be of type function")
ASSERT(OB Instance of($callback; 4D.Function); "Callback must be of type function")
ASSERT($callbackID#""; "Callback ID Method must not be empty")
End if
If (Is macOS)
This._return:=Char(13)
Else
This._return:=Char(13)
End if
// we need to share an object for stop button with progress worker. No need for Storage, only these two processes
// needs access
This.SharedForProgressBar:=New shared object("ID"; 0; "Stop"; False; "EnableButton"; This.stopbutton)
Function onData($systemworker : Object; $data : Object)
var $pos; $progress : Integer
If ($data.data#Null)
This.data.text+=String($data.data)
End if
If (This.type="rclone")
$pos:=Position("%"; $data.data; *)
If ($pos>0)
$progress:=Num(Substring($data.data; $pos-3; 3))
If ($progress#0)
CALL WORKER("FileTransferProgress"; This.callback.source; This.callbackID; $data.data; $progress; This.SharedForProgressBar)
End if
End if
This.data.text:=""
End if
// not needed for Curl
// in Gdrive or Dropbox used when asking for Authentication
If ((This.type="gdrive") && (This.data.text="@Authentication@"))
$systemworker.terminate()
return
End if
If ((This.type="dropbox") && (This.data.text="@authorization@"))
$systemworker.terminate()
return
End if
// check for stop button in progress bar
If (Bool(This.SharedForProgressBar.Stop))
$systemworker.terminate()
return
End if
Function onDataError($systemworker : Object; $data : Object)
var $pos; $progress : Integer
var $message : Text
// called when data is received from curl or dropbox to handle progress bar
// check for stop button in progress bar
If (Bool(This.SharedForProgressBar.Stop))
$systemworker.terminate()
return
End if
If (String($data.data)#"")
This.data.text+=$data.data
//This._createFile("onDataError"; This.data.text) // debug
If (This.callback#Null)
Case of
: (This.type="gdrive")
$pos:=Position(Char(13); This.data.text)
If ($pos>0)
CALL WORKER("FileTransferProgress"; This.callback.source; This.callbackID; Substring(This.data.text; 1; $pos-1); -1; This.SharedForProgressBar)
This.data.text:=Substring(This.data.text; $pos+1)
End if
: (This.type="dropbox")
$pos:=Position(This._return; This.data.text)
If ($pos>0)
If ($pos=Length(This.data.text)) // Dropbox
CALL WORKER("FileTransferProgress"; This.callback.source; This.callbackID; This.data.text; -1; This.SharedForProgressBar)
This.data.text:=""
End if
End if
Else
$pos:=Position(This._return; This.data.text)
$message:=Substring(This.data.text; 1; $pos-1)
This.data.text:=Substring(This.data.text; $pos+1)
$progress:=Num(Substring($message; 1; 3))
If ($progress#0)
CALL WORKER("FileTransferProgress"; This.callback.source; This.callbackID; $message; $progress; This.SharedForProgressBar)
End if
End case
End if
End if
Function onTerminate($systemworker : Object; $data : Object)
If (This.callback#Null)
CALL WORKER("FileTransferProgress"; This.callback.source; This.callbackID; ""; 100; This.SharedForProgressBar)
End if
//This._createFile("onTerminate"; $data.data)
Function _createFile($title : Text; $textBody : Text)
// debug only
TEXT TO DOCUMENT(Get 4D folder(Current resources folder)+$title+".txt"; $textBody)
Function _trim($text : Text)->$result : Text
$result:=$text
While (Substring($result; 1; 1)=" ")
$result:=Substring($result; 2)
End while
While (Substring($result; Length($result); 1)=" ")
$result:=Substring($result; 1; Length($result)-1)
End while
⇧
[class]$composant - 06/02/2026 18:13:57
property matriceInfoPlistFichier : 4D.File
property infoPlistFolder : 4D.Folder
property infoPlist; langues : Collection
property informations; functionID; nomOBJ : Text
Class constructor()
Function InitResult()->$result : Object
$result:=New object
$result.Error:=0
$result.ErrorDescription:=""
$result.success:=True
//--------------------
//MARK:Installation
//--------------------
Function initVariablesSDK()
Use (Storage)
Storage["System"]:=New shared object
Storage["Host"]:=New shared object
Storage["Processes"]:=New shared object
Storage["Saisie"]:=New shared object("enCours"; False)
Storage["RessourcesALV"]:=New shared object
Storage["TraceLogs"]:=New shared object
End use
Use (Storage.System)
Storage.System.estServeurWeb:=False
Storage.System.estExecuteDansHote:=False
Storage.System.estExecuteDansAPP:=False
End use
This.PartagerResources()
Function Installer()
This.InstallerRessourcesAPP()
This.InstallerDonnéesHote()
Function InstallerDonnéesHote()
// lire les données d'installation
var $attribut : Text
var $data : Object
Case of
: (Not(Storage.System.estExecuteDansHote))
// exécution du composant en local
: (Not(Storage.System.estExecuteDansAPP))
// exécution du composant dans un composant
Use (Storage)
Storage.Host:=New shared object
End use
: (Storage.System.typeApplication=ALV Client APP)
: (Storage.System.typeApplication=4D Remote mode)
// filtrer
Else
$data:=New object
// une erreur est générée si l'appel vient d'un composant en test
EXECUTE METHOD(Lire Données Hôte Partagées; $data)
// recopier les données reçues
Use (Storage.Host)
For each ($attribut; OB Keys($data))
Storage.Host[$attribut]:=$data[$attribut]
End for each
End use
End case
Function InstallerRessourcesAPP()
// recopier les chaines localisées partagées : fichiers "LabelsErreur.xlf"
var $dossierSource : 4D.Folder
var $source : 4D.File
var $dossierDestination; $destination : 4D.Folder
var $c : Collection
var $itemText : Text
If (Storage.System.estExecuteDansAPP)
// une ressource APP
$dossierSource:=Folder(fk resources folder; *)
// dans ue ressource composant
$dossierDestination:=Folder(fk resources folder)
$c:=$dossierSource.folders(fk ignore invisible)
This.FixerLanguesApplication()
// pour toutes les langues gérées par l'application
For each ($itemText; This.langues)
Case of
: ($c.query("name"; $itemText).length=0)
// le dossier $itemText.lproj n'existe pas
: ($c.query("name"; $itemText)[0].files().length=0)
// il est vide
: ($c.query("name"; $itemText)[0].files().query("name"; "LabelsErreur").length=0)
// le fichier ressources "Composant_IDnom" n'existe pas
Else
$source:=$dossierSource.file($itemText+".lproj/LabelsErreur.xlf")
$destination:=$dossierDestination.folder($itemText+".lproj")
// recopier le fichir dans le dossier
$source.copyTo($destination; fk overwrite)
End case
End for each
End if
Function PartagerResources()
// partager les ressources SDK
cs.ResourceALV.me.Inscrire(Est Ressource HOST; New object("chemin"; Folder(fk resources folder).file("Hebergement.xml").platformPath))
Function FixerLanguesApplication()
This.langues:=New collection("de"; "en"; "es"; "fr")
//--------------------
//MARK:Génération
//--------------------
Function AfficherLaGeneration($params : Object)
// créer la fenêtre
var $data : Object
var $nomProc : Text
NO DEFAULT TABLE
// la fenêtre est ouverte en taille normale. Le user ne peut pas modifier la taille
$nomProc:="U_Formulaire?Générer Composant"
$data:=cs.$composant.new()
cs.Outils.me.CopierAttributs($params; $data)
$data.wndNum:=Open form window($nomProc; Palette form window; Horizontally centered; Vertically centered; *)
SET WINDOW TITLE("Générateur de composant"; $data.wndNum)
DIALOG($nomProc; $data)
Function _TraiterFORMevent()
If (OB Is defined(FORM Event; "objectName"))
// event d'un objet formulaire
This.functionID:="_fct_"+FORM Event.objectName
This.nomOBJ:=FORM Event.objectName
Else
// event du formulaire
This.functionID:="_fct_Formulaire"
This.nomOBJ:=""
End if
If (OB Is defined(This; This.functionID))
This[This.functionID]()
End if
Function _fct_Formulaire()
Case of
: (Form event code=On Load)
Form.LireInfoPlist()
End case
Function _fct_btnGeneration()
var $data : Object
var $numProc : Integer
Case of
: (Form event code=On Clicked)
// générer le composant
OBJECT SET VISIBLE(*; "bOk"; False)
// mettre à jour le fichier infoPlist
This.EcrireInfoPlist()
// exécution dans un process externe
$data:=OB Copy(Form)
$data.BuildSettingFichierPath:=This.BuildSettingFichierPath()
$data.functionID:="LancerGeneration"
$numProc:=Exécuter Function Coopérative(cs.$composant; $data)
End case
Function LancerGeneration($data : Object)
// générer le composant
var $f : 4D.File
BUILD APPLICATION($data.BuildSettingFichierPath)
$data.success:=(Ok=1)
Waiting(10)
This.getInfoPlistFolder()
This.infoPlistFolder.file("Info.plist").delete()
$f:=This.infoPlistFolder.folder("Resources").file("Info.plist")
$f.copyTo(This.infoPlistFolder)
$data.functionID:="Afficher Success"
CALL FORM($data.wndNum; Formula from string("cs.$composant.new().AfficherSuccess($1)"); $data)
Function AfficherSuccess($data : Object)
// afficher l'état
OBJECT SET VISIBLE(*; "bOk"; $data.success)
OBJECT SET VISIBLE(*; "bKO"; Not($data.success))
// mettre à jour (ici on a perdu la classe du Form ?)
This.LireInfoPlist()
Form.informations:=This.informations
//--------------------
//MARK:Information APP
//--------------------
Function AfficherInfos()
// afficher les infos saisissables
// la version
This.LireVersion()
Function LireVersion()
var $c; $cI : Collection
var $i : Integer
$c:=This.infoPlist.query("key = :1"; "CFBundleShortVersionString")
If ($c.length=1)
$cI:=Split string($c[0].string; ".")
For ($i; 0; 2)
This["shortVersion"+String($i)]:=Num($cI[$i])
End for
End if
Function FixerVersion()->$result : Text
var $c : Collection
var $i : Integer
$c:=New collection
For ($i; 0; 2)
$c.push(String(This["shortVersion"+String($i)]))
End for
$result:=$c.join(".")
Function FixerInfos()
var $texte : Text
$texte:=System info.osVersion
This.FixerInfo("BuildMachineOSBuild"; $texte)
This.FixerInfo("CFBundleDevelopmentRegion"; "French")
This.FixerInfo("CFBundleInfoDictionaryVersion"; "6.0")
$texte:=Folder(Structure file(*); fk platform path).name
This.FixerInfo("CFBundleName"; $texte)
This.FixerInfo("CFBundleDisplayName"; $texte)
This.FixerInfo("CFBundleExecutable"; $texte)
$texte:=This.FixerVersion()
This.FixerInfo("CFBundleShortVersionString"; $texte)
This.FixerInfo("CFBundleVersion"; $texte)
$texte:="©ALV 1998-"+String(Year of(Current date))
This.FixerInfo("NSHumanReadableCopyright"; $texte)
This.FixerInfo("com.4d.minSupportedVersion"; "20")
Function LireInfo($key : Text)->$result : Text
var $c : Collection
$c:=This.infoPlist.query("key = :1"; $key)
If ($c.length=1)
$result:=$c[0].string
Else
$result:="#err Absence info"
End if
Function FixerInfo($key : Text; $string : Text)
// écrire le texte $sting à la clé $key
var $c : Collection
$c:=This.infoPlist.query("key = :1"; $key)
If ($c.length=0)
// structure nouvelle : créer l'entrée
This.infoPlist.push(New object("key"; $key; "string"; ""))
// relancer
$c:=This.infoPlist.query("key = :1"; $key)
End if
$c[0].string:=$string
//--------------------
//MARK:Fichier Plist
//--------------------
Function ExtraireInfos()
// le fichier est une structure XML
// remplir une collection avec les paires key / string du fichier
var $RacineXML; $ElementXML : Text
var $nomKey; $valeurKey; $nomString; $valeurString : Text
This.infoPlist:=New collection
If (This.matriceInfoPlistFichier.exists)
// lire la structure XML
$RacineXML:=DOM Parse XML source(This.matriceInfoPlistFichier.platformPath)
If (ok=1)
$ElementXML:=DOM Find XML element($RacineXML; "dict")
$ElementXML:=DOM Get first child XML element($ElementXML; $nomKey; $valeurKey)
While (ok=1)
// lire la paire ; en principe ici $nomKey = "key"
If ($nomKey="key")
$ElementXML:=DOM Get next sibling XML element($ElementXML; $nomString; $valeurString)
Case of
: ($nomString="string")
This.infoPlist.push(New object("key"; $valeurKey; "string"; $valeurString))
: ($nomString="array")
// pas traité ici
End case
End if
// key de la paire suivante
$ElementXML:=DOM Get next sibling XML element($ElementXML; $nomKey; $valeurKey)
End while
End if
DOM CLOSE XML($RacineXML)
End if
Function LireInfoPlist($fichier : 4D.File)
// lire le contenu du fichier et extraire les informations
// fixer le chemin du fichier
If (Count parameters>0)
This.matriceInfoPlistFichier:=$fichier
Else
This.getMatriceInfoPlistFichier()
End if
This.informations:="Fichier vide"
If (This.matriceInfoPlistFichier.exists)
// afficher les infos
This.informations:=Document to text(This.matriceInfoPlistFichier.platformPath)
End if
// extraire les infos
This.ExtraireInfos()
// afficher les infos saisissables
This.AfficherInfos()
Function EcrireInfoPlist()
var $RacineXML; $ElementXML; $EnfantXML : Text
var $data : Object
var $string : Text
// mettre à jour les infos
This.FixerInfos()
// construire la structure XML
// créer la structure
$RacineXML:=DOM Create XML Ref("plist")
// créer le dico
$ElementXML:=DOM Create XML element($RacineXML; "dict")
For each ($data; This.infoPlist)
$string:=This.LireInfo($data.key)
If ($string="#err@")
// pb
Else
$EnfantXML:=DOM Create XML element($ElementXML; "key")
DOM SET XML ELEMENT VALUE($EnfantXML; $data.key)
$EnfantXML:=DOM Create XML element($ElementXML; "string")
DOM SET XML ELEMENT VALUE($EnfantXML; $string)
End if
End for each
DOM EXPORT TO FILE($RacineXML; This.matriceInfoPlistFichier.platformPath) //génère une erreur
DOM CLOSE XML($RacineXML)
Function getMatriceInfoPlistFichier()
// on utilise un fichier type .plist dans les ressources de la base courante
This.matriceInfoPlistFichier:=Folder(Get 4D folder(Current resources folder; *); fk platform path).file("Info.plist")
Function getInfoPlistFolder()
// on utilise un fichier type .plist dans les ressources du composnt
This.LireInfoPlist()
This.infoPlistFolder:=Folder(Get 4D folder(Current resources folder; *); fk platform path).parent.parent.folder("ALV_Build/Components/"+This.LireInfo("CFBundleExecutable")+".4dbase/Contents/")
Function BuildSettingFichierPath()->$result : Text
// renvoie le fichier "buildApp.4DSettings" de la base courante
$result:=Folder(Get 4D folder(Current resources folder; *); fk platform path).parent.folder("Settings").file("buildApp.4DSettings").platformPath
⇧
[class]ServicesFTP - 21/05/2026 11:17:52
// interface avec la classe $FileTransfert_curl
property ftp : cs.$FileTransfer_curl
property dernierResult : cs.Traces
property erreurFTP : Object
property fct : cs.Outils
property rsc : cs.ResourceALV
property existsParamètres : Boolean
property params : Object
Class extends $document
Class constructor($params : Object)
Super()
If (Count parameters=0)
$params:=New object
End if
// paramètres de connexion
This.existsParamètres:=False
This.ftp:=Null
This.erreurFTP:=Null
This.fct:=cs.Outils.me
This.rsc:=cs.ResourceALV.me
This.params:=New object
// pour le debug, mettre à jour "Session_Etat"
cs.$composant.new().InstallerDonnéesHote()
This.dernierResult:=Null
// initialiser la connexion FTP
This.FixerParametresConnexion($params)
//----------------------------
//MARK:Documents
//----------------------------
Function LireCatalogueDuDossier($url : Text; $catalogue : Pointer; $fichiers : Pointer)->$result : cs.Traces
// le catalogue du répertoire (propriétés des fichiers) est à la racine du répertoire de chemin $url, son nom est celui du dossier + ".b64"
// retourne le catalogue dans $catalogue {, ajoute le contenu à $fichiers}
var $path; $cheminFichier : Text
var $c : Collection
$result:=This.InitResult(Current method name)
$path:=This._getCheminDuCatalogue($url)
$cheminFichier:=Temporary folder+String(Random)+".alvtmp"
Case of
: (Count parameters<1)
$result.Error:=-15068
$result.ErrorDescription:="$2 n'est pas défini"
: (Type($catalogue->)#Is object)
$result.Error:=-15068
$result.ErrorDescription:="$2 n'est pas un objet"
// le rapatrier le fichier
: (Not(This.RecevoirFichier($path; $cheminFichier).success))
$result.Error:=10054
$result.ErrorDescription:="le document "+$path+" n'existe pas"
Else
// lire les données
SET BLOB SIZE($blob; 0)
DOCUMENT TO BLOB($cheminFichier; $blob)
BLOB TO VARIABLE($blob; $catalogue->)
DELETE DOCUMENT($cheminFichier)
End case
// mémoriser l'erreur locale
$result[Current method name+"Error"]:=$result.Error
$result[Current method name+"ErrorDescription"]:=$result.ErrorDescription
$result.FixerSuccess()
// l'erreur peut être normale ; ne pas générer d'erreur
$c:=New collection
Case of
// on demande la liste des fichiers
: (Count parameters<3)
//lire les fichiers
: (Not(This.ListerLesDocuments($url; ->$c).success))
// il y a des fichiers
: ($c.length=0)
// on a un tableau texte
: (Type($fichiers->)#Text array)
Else
// il n'y a pas que des fichiers ALV (fichiers UNIX...)
COLLECTION TO ARRAY($c; $fichiers->; "nom")
End case
Function EcrireCatalogueDuDossier($url : Text; $catalogue : Object)->$result : cs.Traces
// le catalogue du répertoire, $catalogue (propriétés des fichiers), est à la racine du répertoire
// chemin du catalogue $url, le nom du catalogue est celui du dossier + ".b64"
var $path; $nom; $fichier : Text
$result:=This.InitResult(Current method name)
// obtenir le nom du dossier
ARRAY TEXT($Elements; 0)
GET TEXT KEYWORDS($url; $Elements)
// fixer le nom du catalogue
$nom:=Split string($url; "/"; sk ignore empty strings).pop()+".b64"
$nom:=$Elements{Size of array($Elements)}+".b64"
// ATTENTION : malgré son extension, le fichier n'est pas encodé en Base64
// créer le nouveau fichier
SET BLOB SIZE($blob; 0)
VARIABLE TO BLOB($catalogue; $blob)
$fichier:=Temporary folder+String(Random)+".b64"
BLOB TO DOCUMENT($fichier; $blob)
// obtenir le chemin du répertoire amont dans $path
$path:=$url
// revenir au répertoire amont
If (This.getCheminDuRepertoire(->$path)=0)
// chemin FTP complet du catalogue
$nom:=$path+$nom
// transférer le nouveau
If (This.EnvoyerFichier($fichier; $nom).Error=0)
// tout est ok ici
Else
$result.Error:=-16002
End if
Else
$result.Error:=-16001
End if
// nettoyer
DELETE DOCUMENT($fichier)
$result.ErrorLabel:=Localized string(String($result.Error))
$result.FixerSuccess()
$result.LeverException([msgk_event])
Function MettreAjourDossier($params : Object)->$result : cs.Traces
// l'avancement de la tâche varie de 0 à 1
var $tâche : cs.Tache
var $cheminDestination; $path; $texte; $ProcInProgressEtat : Text
var $options : Integer
var $dossierTravail; $dossier; $fichier; $data; $infosItems; $infosItem : Object
var $fichiersDestination; $c : Collection
$result:=This.InitResult(Current method name)
Case of
: ($result.success=False)
: (Not(OB Is defined($params; "dossier")))
$result.Error:=-15068
$result.ErrorDescription:="$1.dossier est absent"
: (Not(OB Is defined($params; "cheminFTP")))
$result.Error:=-15068
$result.ErrorDescription:="$1.cheminFTP est absent"
: (Not(OB Is defined($params; "Options")))
$result.Error:=-15068
$result.ErrorDescription:="$1.Options est absent"
: (Not(OB Is defined($params; "tache")))
$result.Error:=-15068
$result.ErrorDescription:="$1.tache est absent"
Else
$result.Error:=0
// on y est
// la tâche est monitorée par l'extérieur
$tâche:=$params.tache
$tâche.FixerAvancement(0) // init. l'avancement
$tâche.FixerState(0) // sera le nombre de mises à jour
// nettoyer (au cas où le process n'a pas été au bout)
$tâche.FixerEtat("Transfert du dossier "+$params.dossier.name)
// fixer le dossier de travail
$dossierTravail:=Folder(Temporary folder+"tempoExport"; fk platform path)
If ($dossierTravail.exists)
$dossierTravail.delete(Delete with contents)
End if
$dossierTravail.create()
// récupérer les paramètres
$dossier:=$params.dossier
$cheminDestination:=$params.cheminFTP
$options:=$params.Options
// indicateur de mise à jour du fichier des propriétés fichiers
$options:=$options ?- 23
// le transfert se fait toujours avec l'option 3 = 1
If ($dossier.isFolder)
$fichiersDestination:=New collection
For each ($data; $dossier.files(fk recursive+fk ignore invisible))
// par défaut, nom avec extension (fichiers .html, .dmg, .zip ...)
$path:=$data.fullName
// l'extention du fichier est .typeOrigine
If ($options ?? 5)
// // fixer le type des fichiers à "xfam". l'extention du fichier est .xfam
$path:=$data.name+".xfam"
End if
// fixer l'encodage des fichiers
If ($options ?? 6)
// pas le choix : base64. L'extention du fichier devient .typeOrigine.b64 ou .xfam.b64
$path:=$path+".b64"
End if
$fichiersDestination.push(New object("fichier"; $data; "cheminFTP"; $path))
End for each
// liste des fichiers existants
$c:=New collection
Case of
: ($fichiersDestination.length=0)
// créer le répertoire destination (au cas où), le désigner répertoire courant
: (This.CréerRépertoire($cheminDestination).Error#0)
: (This.ListerLesDocuments($cheminDestination; ->$c).Error#0)
Else
// gérer la date/heure des fichiers
If ($options ?? 1)
// pour faire la mise à jour des fichiers, la date / heure vraie des documents ALV (différents de ceux du fichier sur le serveur) doivent être connues
// elles sont mémorisées dans un fichier à part : le lire
// remarque : une façon de forcer la mise à jour tout le dossier $3 consiste à supprimer ce fichier (par un autre client FTP comme FileZilla)
$infosItems:=New object
$result:=This.LireCatalogueDuDossier($params.cheminFTP; ->$infosItems)
End if
// tout est Ok, mettre à jour ces fichiers
// remarque : en procédant sur $fichiersDestination, on n'a pas à se soucier des autres éléments récupérés dans $c (type dossier, fichiers cachés, UNIX...)
// créer les données à envoyer
For each ($data; $fichiersDestination) While (Not($tâche.Tuer.signaled))
$result.Error:=0 // raz des erreurs
$result.ErrorDescription:=""
// fixer son transfert
$data.transférer:=False
$ProcInProgressEtat:=$data.fichier.fullName
Case of
: ($c.query("nom = :1"; $data.cheminFTP).length=0)
// le fichier n'existe pas, le transférer
$data.transférer:=True
$ProcInProgressEtat:="Ajout de "+$ProcInProgressEtat
: ((($c.query("nom = :1"; $data.cheminFTP).length>0) & ($options ?? 0)))
// il existe, mais forcer le transfert
$ProcInProgressEtat:="Remplacement de "+$ProcInProgressEtat
If ($options ?? 1)
// on ne met à jour que si l'existant est plus ancien
// lire la date du fichier
If (OB Is defined($infosItems; $data.cheminFTP))
// faire une copie plutot qu'une lecture; la variable va être modifiée par la suite pour autre chose
$infosItem:=OB Copy(OB Get($infosItems; $data.cheminFTP; Is object))
$data.transférer:=(($data.fichier.modificationDate>OB Get($infosItem; "dateModification"; Is date)) | (($data.fichier.modificationDate=OB Get($infosItem; "dateModification"; Is date)) & ($data.fichier.modificationTime>OB Get($infosItem; "heureModification"; Is time))))
Else
// les données du fichier ne sont pas connues : on met tout à jour
$data.transférer:=True
End if
$ProcInProgressEtat:=$ProcInProgressEtat+" du "+String(OB Get($infosItem; "dateModification"; Is date); System date short)+" à "+String(OB Get($infosItem; "heureModification"; Is time); HH MM SS)+", par celui du "+String($data.fichier.modificationDate; System date short)+" à "+String(OB Get($data.fichier; "modificationTime"; Is time); HH MM SS)
Else
// forcer la mise à jour
$data.transférer:=True
End if
End case
// crypter / encoder
$data.Erreur:=0
If ($data.transférer)
// créer une copie du fichier source
$data.fichierAjour:=$data.fichier.copyTo($dossierTravail; "FTP_"+String(Random)+"_"+$data.fichier.fullName; fk overwrite)
// crypter le fichier, avec les clés "admin"
If ($options ?? 5)
// crypter avec la clé fournie et récupérer le chemin du fichier crypté
$fichier:=$data.fichierAjour
If (OB Is defined($params; "cryptage"))
$result:=This.CrypterALV($fichier; $dossierTravail; $params.cryptage)
// le fichier crypté est dans $result
$data.fichierAjour:=$result.fichier
Else
$result.Error:=-15068
$result.ErrorDescription:="$params.cryptage est absent"
End if
End if
// encoder le fichier
If (($result.Error=0) & ($options ?? 6))
// encoder le fichier en base64
$result:=This.EncoderBase64($data.fichierAjour)
// le fichier encodé est dans $result avec la bonne extension (.b64)
$data.fichierAjour:=$result.fichier
End if
$data.Erreur:=$result.Error
// avertir d'une erreur
$result.ErrorLabel:=Localized string(String($result.Error))
$result.LeverException([msgk_log; msgk_event])
End if
// renseigner la progression
If ($data.transférer)
$tâche.FixerEtat($ProcInProgressEtat)
End if
$tâche.FixerState(Choose($data.transférer; $tâche.State+1; $tâche.State))
$tâche.FixerAvancement(0.5*($fichiersDestination.indexOf($data)+1)/$fichiersDestination.length)
End for each
// envoyer les fichiers
$result.rapport:=New collection
For each ($data; $fichiersDestination) While (Not($tâche.Tuer.signaled))
// fichier à envoyer
$path:=$data.fichierAjour.platformPath
// chemin FTP destination
$texte:=$cheminDestination+$data.cheminFTP
$result.Error:=0
Case of
: ($data.transférer=False)
// fichier sur le serveur OK
: ($data.Erreur#0)
// erreur de création du nouveau fichier
Else
// tracer le traitement
$result.rapport.push("Envoi de "+$path+" dans "+$texte)
// renseigner la progression
$tâche.FixerEtat(Choose($data.transférer; $result.rapport.at(-1); ""))
$tâche.FixerState(Choose($data.transférer; $tâche.State+1; $tâche.State))
$tâche.FixerAvancement(0.5+(0.5*($fichiersDestination.indexOf($data)+1)/$fichiersDestination.length))
$data.result:=This.EnvoyerFichier($path; $texte)
If (($data.result.Error=0) & ($options ?? 1))
// mettre à jour les données du fichier
OB SET($infosItem; "dateModification"; $data.fichier.modificationDate; "heureModification"; $data.fichier.modificationTime)
OB SET($infosItems; $data.cheminFTP; OB Copy($infosItem))
End if
// avertir d'une erreur
$data.result.ErrorLabel:=Localized string(String($data.result.Error))
$data.result.LeverException([msgk_log; msgk_event])
End case
End for each
Waiting(2)
// créer le nouveau fichier
If ($options ?? 1)
$data.result:=This.EcrireCatalogueDuDossier($cheminDestination; $infosItems)
End if
// supprimer les fichiers orphelins de destination ($c)
If ($options ?? 2)
For each ($data; $c)
// filtrer les fichiers base64 (plétore de fichiers système...)
If (($fichiersDestination.query("cheminFTP"; $data.nom).length=0) & ($data.nom=".b64"))
// ce fichier n'est pas dans ce qui est supposé exister ($fichiersDestination)
$data.result:=This.SupprimerFichier($cheminDestination+$data.nom)
End if
If ($tâche.Tuer.signaled) // saborder
break
End if
End for each
End if
$result.Error:=$data.result.Error
$result.ErrorDescription:=$data.result.ErrorDescription
End case
Else
$result.Error:=-15068
$result.ErrorDescription:="le paramètre $2 n'est pas un dossier"
End if
// c'est fini
If ($options ?? 4)
$params.dossier.delete(Delete with contents)
End if
// nettoyer
$dossierTravail.delete(Delete with contents)
$result.ErrorLabel:=Localized string(String($result.Error))
$result.LeverException([msgk_event])
End case
$result.FixerSuccess()
Function TelechargerFichier($params : Object; $cheminDossier : Text)->$result : cs.Traces
var $c : Collection
var $fichier : 4D.File
var $dossierDestination : 4D.Folder
var $chemin : Text
$result:=This.InitResult(Current method name)
$result.Error:=-15068
$result.ErrorDescription:=""
Case of
: (Not(OB Is defined($params; "urlDossier")))
$result.ErrorDescription:="$1.urlDossier est absent"
: (Not(OB Is defined($params; "nomFichier")))
$result.ErrorDescription:="$1.nomFichier est absent"
Else
$chemin:=Temporary folder+$params.nomFichier
$c:=New collection
Case of
// lire le contenu
: (This.ListerLesDocuments($params.urlDossier; ->$c).Error#0)
// chercher le fichier
: ($c.query("nom = :1"; $params.nomFichier).length=0)
// le fichier n'existe pas
$result.Error:=-15066
$result.ErrorDescription:="Le fichier "+$params.nomFichier+" est absent du dossier "+$params.urlDossier
// le fichier existe, le télécharger
: (This.RecevoirFichier($params.urlDossier+$params.nomFichier; $chemin).Error#0)
Else
// ici c'est ok
$result.Error:=0
$fichier:=File($chemin; fk platform path)
// décodage
If (Position(".b64"; $params.nomFichier)>0)
$result:=This.DécoderBase64($fichier)
$fichier:=$result.fichier
End if
// décryptage
Case of
: ($fichier=Null)
: (Position(".xfam"; $params.nomFichier)=0)
Else
$result:=This.DéCrypterALV($fichier; Null; New object("groupID"; -15001))
$fichier:=$result.fichier
End case
// recopier le fichier à l'endroit demandé
If ($fichier#Null)
$dossierDestination:=Folder($cheminDossier; fk platform path)
If (Not($dossierDestination.exists))
$dossierDestination.create()
End if
// remarque : cette copie valide le transfert FTP pour l'appelant (pas de fichier = error)
// donc pas besoin de faire remonter l'erreur
$result.fichier:=$fichier.copyTo($dossierDestination)
$fichier.delete()
End if
End case
End case
$result.FixerSuccess()
This.dernierResult:=$result
//----------------------------
//MARK:Transfert fichiers
//----------------------------
Function RecevoirFichier($url : Text; $cheminFichier : Text)->$result : cs.Traces
// recevoir le fichier de chemin relatif $url, le mettre dans le fichier $cheminFichier
var $path : Text
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
If (Test path name($cheminFichier)=Is a document)
DELETE DOCUMENT($cheminFichier)
End if
$path:=Convert path system to POSIX($cheminFichier)
This.ftp.setAutoCreateRemoteDirectory(True)
This.ftp.setAutoCreateLocalDirectory(True)
This.erreurFTP:=This.ftp.download($url; $path)
$result.Error:=10054*Num(Not(This.erreurFTP.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
End if
$result.FixerSuccess()
This.dernierResult:=$result
Function RecevoirDossier($url : Text; $cheminDossier : Text; $options : Integer)->$result : Object
// $1 et $2 sont des chemins de dossier,
// bit 0 = remplacer si existe,
// bit 1 = remplacer si plus ancien,
// bit 2 = supprimer dans destination les fichiers orphelins,
// bit 3 = copier dans un seul dossier
// bit 8 = recevoir les fichiers
// bit 9 = traiter les sous dossiers de $cheminDossier
var $c; $items : Collection
var $item : Object
If ($url#"@/")
$url:=$url+"/"
End if
$result:=This.ListerLesDocuments($url; ->$c)
Case of
: (Not($result.success))
$result.Error:=10054*Num(Not($result.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
: ($c.length=0)
$result.Error:=15068
$result.ErrorDescription:="le dossier '"+$url+"' est vide"
Else
// ramener les fichiers
$items:=$c.query("type = :1"; Is a document)
Case of
: (Not($options ?? 8))
: ($items.length=0)
Else
For each ($item; $items)
$result:=This.RecevoirFichier($url+$item.nom; $cheminDossier+$item.nom)
End for each
End case
// reboucler sur les dossiers
$items:=$c.query("type = :1"; Is a folder)
Case of
: (Not($options ?? 9))
: ($items.length=0)
Else
For each ($item; $items)
$result:=This.RecevoirDossier($url+$item.nom; $cheminDossier+$item.nom+Folder separator; $options)
End for each
End case
End case
$result.FixerSuccess()
Function EnvoyerDossier($dossier : Object; $url : Text)->$result : cs.Traces
// transférer le contenu du dossier $Dossier au chemin $url
// envoie les sous dossiers si existent
var $élément : Object
var $path : Text
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
For each ($élément; $dossier.files(fk ignore invisible))
$result:=This.EnvoyerFichier($élément.platformPath; $url)
End for each
For each ($élément; $dossier.folders(fk ignore invisible))
// reboucler sur le dossier
$path:=$url+$élément.name+"/"
$result:=This.CréerRépertoire($path)
$result:=This.EnvoyerDossier($élément; $path)
End for each
End if
$result.FixerSuccess()
Function EnvoyerFichier($cheminFichier : Text; $url : Text)->$result : cs.Traces
var $path : Text
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
If (Test path name($cheminFichier)=Is a document)
$path:=Convert path system to POSIX($cheminFichier)
This.ftp.setAutoCreateRemoteDirectory(True)
This.ftp.setAutoCreateLocalDirectory(True)
This.erreurFTP:=This.ftp.upload($path; $url)
$result.Error:=10054*Num(Not(This.erreurFTP.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
Else
$result.Error:=-15068
$result.ErrorDescription:=$cheminFichier+" n'est pas un fichier"
End if
End if
$result.FixerSuccess()
Function SupprimerFichier($url : Text)->$result : cs.Traces
// supprimer le fichier de chemin relatif $url
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
This.erreurFTP:=This.ftp.deleteFile($url)
$result.Error:=10054*Num(Not(This.erreurFTP.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
End if
$result.FixerSuccess()
Function CréerRépertoire($url : Text)->$result : cs.Traces
// créer la hiérarchie de sous dossiers $url
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
This.erreurFTP:=This.ftp.createDirectory($url)
$result.Error:=10054*Num(Not(This.erreurFTP.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
End if
$result.FixerSuccess()
Function SupprimerRépertoire($url : Text)->$result : cs.Traces
// supprimer la hiérarchie de sous dossiers $url
var $c : Collection
var $item : Object
$result:=This.InitResult(Current method name)
If (This.existsParamètres)
// le dossier $url doit être vide pour pouvoir le supprimer
Case of
: (Not(This.ListerLesDocuments($url; ->$c).success))
// le répertoire n'existe pas ?
: ($c.length=0)
// dossier vide, on vide
This.erreurFTP:=This.ftp.deleteDirectory($url)
Else
// vider le dossier
For each ($item; $c)
Case of
: ($item.type=Is a document)
$result:=This.SupprimerFichier($url+$item.nom)
: ($item.type=Is a folder)
// récursivité
$result:=This.SupprimerRépertoire($url+$item.nom+"/")
End case
End for each
// supprimer le dossier
This.erreurFTP:=This.ftp.deleteDirectory($url)
$result.Error:=This.erreurFTP.Error
End case
End if
$result.FixerSuccess()
//----------------------------
//MARK:Informations sur host
//----------------------------
Function ListerLesDocuments($url : Text; $catalogue : Pointer)->$result : cs.Traces
// renvoyer le contenu du dossier de chemin $1 dans $2
var $ligne; $document : Object
$result:=This.InitResult(Current method name)
$result.Error:=-15068
Case of
: (Not((This.existsParamètres)))
$result.ErrorDescription:="err Paramètres de connexion"
: (Type($catalogue->)#Is collection)
$result.ErrorDescription:="$2 n'est pas une collection"
Else
This.erreurFTP:=This.ftp.getDirectoryListing($url)
$result.Error:=10054*Num(Not(This.erreurFTP.success))
$result.FixerSuccess()
Case of
: (Not($result.success))
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
: (This.erreurFTP.list.length=0)
$result.ErrorDescription:="la liste de '"+$url+"' est vide"
Else
$catalogue->:=New collection
For each ($ligne; This.erreurFTP.list)
// -rw----r-- 1 6209 users 302740 Jan 29 2023 03474.xfam.b64
// rmk : le champ heure est en général absent ; l'heure peut être à la place de l'année !
// -rw----r-- 1 6209 users 15645336 May 26 09:09 03494.xfam.b64
Case of
: ($ligne.path=".@")
: ($ligne.path="..@")
// en principe 8 attributs
//: (Num($ligne.type)<1)
//: (Num($ligne.type)>2)
// seules les lignes de type 1 et 2 (fichier dossier) sont utiles
Else
$document:=New object
$document.nom:=$ligne.path
$document.type:=Choose($ligne.path="@.@"; Is a document; Is a folder) //Num($ligne.type)
$document.taille:=Num($ligne.size)
$document.date:=$ligne.date
$document.heure:=$ligne.time
$catalogue->push($document)
End case
End for each
ASSERT(cs.Traces.new().DebugerVariables(Storage.host.Session_Etat; "SDK"; "Resultat"; Current method name; New object("url"; $url; "contenu"; This.erreurFTP.list)))
End case
End case
$result.FixerSuccess()
Function getFileInfo($url : Text; $data : Pointer)->$result : cs.Traces
// créer la hiérarchie de sous dossiers $url
var $path : Text
var $c : Collection
var $infos : Object
$path:=$url
This.getCheminDuRepertoire(->$path)
// nom du fichier $1
$url:=Replace string($url; $path; "")
// liste des fichiers où se trouve $1
$c:=New collection
$result:=This.ListerLesDocuments($path; ->$c)
Case of
: (Type($data->)#Is object)
$result.Error:=-15068
$result.ErrorDescription:="$2 n'est pas un pointeur objet"
: (Not($result.success))
$result.Error:=10054
$result.ErrorDescription:=$url+" : "+JSON Stringify(This.ftp.status())
// le fichier existe ?
: ($c.length=0)
$result.Error:=-15068
$result.ErrorDescription:="le repertoire '"+$path+"' est vide"
: ($c.query("nom = :1"; $url).length=0)
$result.Error:=-15068
$result.ErrorDescription:="le fichier '"+$url+"' est introuvable dans le repertoire '"+$path+"'"
Else
$infos:=$c.query("nom = :1"; $url)[0]
$data->:=New object
If (OB Is defined($infos; "date"))
$data->date:=$infos.date
End if
If (OB Is defined($infos; "heure"))
$data->heure:=Time(OB Get($infos; "time"; Is longint))
End if
If (OB Is defined($infos; "taille"))
// on a une taille en octets
$data->taille:=OB Get($infos; "size"; Is longint)
End if
End case
$result.FixerSuccess()
Function FixerParametresConnexion($params : Object)->$result : cs.Traces
// renvoie les infos pour accéder à l'hébergeur
var $identifiant; $motDePasse; $hébergement : Text
var $timeOut : Integer
This.existsParamètres:=False
$result:=This.InitResult(Current method name) // init faux
$hébergement:=""
$identifiant:=""
$motDePasse:=""
Case of
: (Not(OB Is defined($params; "hébergement")))
: (Not(OB Is defined($params; "identifiant")))
: (Not(OB Is defined($params; "motDePasse")))
Else
// tout est ok
$hébergement:=$params.hébergement
$identifiant:=$params.identifiant
$motDePasse:=$params.motDePasse
This.existsParamètres:=True
$result:=This.InitResult(Current method name)
End case
Case of
: (This.existsParamètres)
// on a les données
: (Not(This.rsc.SetVariable(Est Ressource HOST; "Connexion/NomHost"; Is text; ->$hébergement)))
$result.ErrorDescription:="'Connexion/NomHost' est absent des ressources"
: (Not(This.rsc.SetVariable(Est Ressource HOST; "Connexion/Identifiant"; Is text; ->$identifiant)))
$result.ErrorDescription:="'Connexion/Identifiant' est absent des ressources"
: (Not(This.rsc.SetVariable(Est Ressource HOST; "Connexion/MotDePasse"; Is text; ->$motDePasse)))
$result.ErrorDescription:="'Connexion/MotDePasse' est absent des ressources"
Else
// tout est ok
This.existsParamètres:=True
$result:=This.InitResult(Current method name)
End case
If (This.existsParamètres)
$timeOut:=5
If (OB Is defined($params; "timeOut"))
$timeOut:=$params.timeOut
End if
This.ftp:=cs.$FileTransfer_curl.new($hébergement; $identifiant; $motDePasse; "ftp")
// certains serveurs ont du mal à se réveiller (sourderie !) . le time out est paramétré
This.ftp.setConnectTimeout($timeOut)
End if
$result.ErrorLabel:=Localized string(String($result.Error))
$result.FixerSuccess()
$result.LeverException([msgk_event])
Function FixerAccessBDDduMedia($params : Object)->$result : cs.Traces
$result:=This.InitResult(Current method name)
Case of
: (Not(OB Is defined($params; "ID")))
$result.Error:=-15067
$result.ErrorDescription:="IDmedia absent"
$result.success:=False
: (Not(This._VolumeDuMedia($params)))
$result.Error:=-15067
$result.ErrorDescription:="Impossible de déterminer le ID volume du media "+String($params.ID)
$result.success:=False
Else
// ajouter le chemin FTP du media ID = $params->ID
This.rsc.SetObjet(Est Ressource HOST; "Chemins/Media/Dossier"; Is text; $params; "urlDossier")
$params.urlDossier:=$params.urlDossier+"folder_"+String($params.volume)+"/"
End case
$result.FixerSuccess()
Function FixerAccessBDDdesMedias($params : Object)->$result : cs.Traces
$result:=This.InitResult()
// on veut le chemin des dossiers
This.rsc.SetObjet(Est Ressource HOST; "Chemins/Media/Dossier"; Is text; $params; "urlDossier")
// ajouter les infos pour le cryptage des media
$params.cryptage:=New object
// chemin du dossier de la clé privée
$params.cryptage.dossierCléPrivée:=Get 4D folder(Current resources folder)
// ID groupe à utiliser
$params.cryptage.groupID:=-15001
Function FixerAccessMisesAjour($params : Object)->$result : Object
$result:=This.InitResult()
// ajouter le chemin FTP des fichiers de mise à jour
This.rsc.SetObjet(Est Ressource HOST; "Chemins/UpdateFiles/Path"; Is text; $params; "urlDossier")
Function FixerAccessInstallateurs($params : Object)->$result : Object
$result:=This.InitResult()
// ajouter le chemin FTP des installateurs
This.rsc.SetObjet(Est Ressource HOST; "Chemins/Installateurs/Path"; Is text; $params; "urlDossier")
Function FixerAccessDocumentation($params : Object)->$result : Object
$result:=This.InitResult()
// ajouter le chemin FTP du dossier de la documentation
This.rsc.SetObjet(Est Ressource HOST; "Chemins/Documentation/Path"; Is text; $params; "urlDossier")
//----------------------------
//MARK:Utilitaires
//----------------------------
Function getCheminDuRepertoire($url : Pointer)->$result : Integer
// remonter d'un niveau la hiérarchie des répertoires de $url
var $c : Collection
$c:=Split string($url->; "/"; sk ignore empty strings)
// supprimer le dernier dossier
$c:=$c.resize($c.length-1)
// reconstruire le chemin
$url->:="/"+$c.join("/")+"/"
$result:=0
Function InitResult($nomMethode : Text)->$result : cs.Traces
$result:=cs.Traces.new().CréerErreur("SDK"; 0; $nomMethode; "")
// erreur si absence des params
If (Not(This.existsParamètres))
$result.Error:=-15012
$result.ErrorDescription:="err Paramètres de connexion"
$result.success:=False
End if
Function _getCheminDuCatalogue($url : Text)->$result : Text
// remplacer ../nom/ par .../nom.b64
var $c : Collection
$c:=Split string($url; "/"; sk ignore empty strings)
// nom du fichier
// ATTENTION : malgré son extension, le fichier n'est pas encodé en Base64
$result:=$c.pop()+".b64"
// reconstruire le chemin
$result:="/"+$c.join("/")+"/"+$result
Function _VolumeDuMedia($params : Object)->$result : Boolean
// renvoyer dans $1 le ID du volume de l'entité $1
var $ID; $volume : Integer
$result:=True
$params.volume:=0
// ID du dossier et son volume du media
$ID:=$params.ID
Begin SQL
SELECT Dossiers.ID, Dossiers.volume FROM Dossiers
INNER JOIN Fichiers ON Fichiers.dossier = Dossiers.ID
WHERE Fichiers.media = :$ID
INTO :$ID, :$volume;
End SQL
// remonter la chaine de sous dossiers jusqu'à la racine (n° volume > 0)
If ($ID>0)
While ($volume<0)
// dossier précédent
Begin SQL
SELECT dossier FROM Arborescence WHERE SousDossier = :$ID INTO :$ID;
SELECT volume FROM Dossiers WHERE ID = :$ID INTO :$volume;
End SQL
End while
$params.volume:=$volume
Else
$result:=False
End if
⇧
[class]$document - 28/04/2025 08:53:49
property XML : cs.XML
Class extends $composant
Class constructor()
Super()
This.XML:=cs.XML.me
//--------------------
//MARK:Chemin
//--------------------
Function getStructureFolder()->$result : 4D.Folder
Case of
: (Application type=4D Volume desktop)
// application fusionnée
$result:=Folder(fk applications folder).folder("Contents/Database")
: ((Application type=4D Server) & (Structure file(*)="@.4DProject"))
// serveur HTTP
$result:=Folder(Structure file(*); fk platform path).parent.parent
: (Application type=4D Server)
// serveur APP
$result:=Folder(fk applications folder).folder("Contents/Server Database")
Else
// BDDmère
$result:=Folder(Structure file(*); fk platform path).parent.parent
End case
Function CalculerNiveauRelatifPOSIX($texte : Text)->$result : Text
$result:="../"*Split string($texte; "/"; sk ignore empty strings).length
//--------------------
//MARK:CoDec
//--------------------
Function EncoderBase64($fichier : 4D.File)->$result : cs.Traces
// encoder le fichier $1 en base64 (fait grossir les fichiers de 33 %)
var $blob : 4D.Blob
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
$result.Error:=15068
Case of
: (Not($fichier.exists))
$result.ErrorDescription:="le fichier $1 n'existe pas"
Else
$result.Error:=0
$blob:=4D.Blob.new()
DOCUMENT TO BLOB($fichier.platformPath; $blob)
BASE64 ENCODE($blob)
// placer le fichier encodé à coté de l'original
$result.fichier:=$fichier.parent.file($fichier.name+".b64")
BLOB TO DOCUMENT($result.fichier.platformPath; $blob)
// nettoyer le fichier original
$fichier.delete()
End case
Function DécoderBase64($fichier : 4D.File)->$result : cs.Traces
var $blob : 4D.Blob
$result:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
$result.Error:=15068
$result.fichier:=Null
Case of
: (Not($fichier.exists))
$result.ErrorDescription:="le fichier $1 n'existe pas"
Else
$result.Error:=0
$blob:=4D.Blob.new()
DOCUMENT TO BLOB($fichier.platformPath; $blob)
BASE64 DECODE($blob)
// placer le fichier décodé à coté de l'original
$result.fichier:=$fichier.parent.file(Replace string($fichier.name; ".b64"; ""))
BLOB TO DOCUMENT($result.fichier.platformPath; $blob)
// nettoyer le fichier original
$fichier.delete()
End case
//--------------------
//MARK:Cryptage
//--------------------
Function CrypterALV($fichier : 4D.File; $dossier : 4D.Folder; $data : Object)->$result : cs.Traces
// crypter le fichier $1 avec la clé fournie $3 et récupérer le chemin du fichier crypté
// v5.3.12 : le cryptage de gros fichiers prend beaucoup de temps :
// . le fichier crypté contient un blob (non crypté) du document et un blob (crypté) du data du document
// . le nom du fichier crypté ne contient plus le type du document
var $fichierCrypté; $fichierTempo : Object
var $modificationDate : Date
var $modificationHeure : Time
var $typeDoc : Text
// lire clé privée du groupe demandé dans $3
SET BLOB SIZE($CléPrivée; 0)
$data.trousseau:="private_key"
$result:=This.LireCleCryptage(->$CléPrivée; $data)
If ($result.Error=0)
// dans l'ordre : les données du document (crypté) puis le document
// données du document
$typeDoc:=$fichier.extension
$modificationDate:=$fichier.modificationDate
$modificationHeure:=$fichier.modificationTime
SET BLOB SIZE($dataCrypté; 0)
VARIABLE TO BLOB($typeDoc; $dataCrypté; *)
VARIABLE TO BLOB($modificationDate; $dataCrypté; *)
VARIABLE TO BLOB($modificationHeure; $dataCrypté; *)
ENCRYPT BLOB($dataCrypté; $CléPrivée)
// le document
SET BLOB SIZE($docOrigine; 0)
DOCUMENT TO BLOB($fichier.platformPath; $docOrigine)
// créer le blob du fichier crypté dans $docBlob
SET BLOB SIZE($docBlob; 0)
VARIABLE TO BLOB($dataCrypté; $docBlob; *)
VARIABLE TO BLOB($docOrigine; $docBlob; *)
// créer le fichier temporaire crypté; son chemin :
$fichierTempo:=Folder(Temporary folder; fk platform path).file("XYZ"+String(Random)+".xfam")
BLOB TO DOCUMENT($fichierTempo.platformPath; $docBlob)
$result.Error:=-15019*Num(ok=0) // erreur de cryptage
If ($result.Error=0) // tout ok : créer le doc final
// créer le document définitif : plusieurs cas
Case of
: ($dossier=Null)
// on met le fichier à côté de l'original
$fichierCrypté:=$fichierTempo.copyTo($fichier.parent; $fichier.name+".xfam"; fk overwrite)
: ($dossier.exists)
// le dossier est imposé
$fichierCrypté:=$fichierTempo.copyTo($dossier; $fichier.name+".xfam"; fk overwrite)
Else
$fichierCrypté:=Null
$result.Error:=-15019
$result.ErrorDescription:=$dossier.platformPath
End case
End if
// nettoyer supprimer le fichier temporaire
$fichierTempo.delete()
End if
$result.fichier:=Null
If ($result.Error=0)
// renvoyer le fichier
$result.fichier:=$fichierCrypté
// nettoyer le fichier non crypté
$fichier.delete()
End if
$result.FixerSuccess()
// l'erreur est levée par l'appelant
Function DéCrypterALV($fichier : 4D.File; $destination : Object; $data : Object)->$result : cs.Traces
// décrypter le fichier $1
var $fichierDéCrypté; $fichierTempo : Object
var $modificationDate : Date
var $modificationHeure : Time
var $typeDoc : Text
var $offset : Integer
// lire clé publique du groupe demandé dans $3
SET BLOB SIZE($CléPublique; 0)
$data.trousseau:="public_key"
$result:=This.LireCleCryptage(->$CléPublique; $data)
// lire le fichier
$result.fichier:=Null
If ($result.Error=0)
SET BLOB SIZE($docBlob; 0)
DOCUMENT TO BLOB($fichier.platformPath; $docBlob)
// lire le blob dans l'ordre :
// - les données d'origine du document
$offset:=0
SET BLOB SIZE($dataCrypté; 0)
Try
BLOB TO VARIABLE($docBlob; $dataCrypté; $offset)
DECRYPT BLOB($dataCrypté; $CléPublique)
Catch
$result.Error:=-15018 // erreur de décryptage
$result.ErrorDescription:="Erreur de décryptage des données du fichier "+$fichier.platformPath
End try
// - le blob du document
If ($result.Error=0)
SET BLOB SIZE($docOrigine; 0)
BLOB TO VARIABLE($docBlob; $docOrigine; $offset)
$result.Error:=-15018*Num(ok=0) // erreur de décryptage
$result.ErrorDescription:="fichier "+$fichier.platformPath
End if
If ($result.Error=0)
$offset:=0
// lire les data du document :
// - le type d'origine du document
BLOB TO VARIABLE($dataCrypté; $TypeDoc; $offset)
// - date / heure d'origine
If ($offset<BLOB size($dataCrypté))
BLOB TO VARIABLE($dataCrypté; $modificationDate; $offset)
BLOB TO VARIABLE($dataCrypté; $modificationHeure; $offset)
Else
$modificationDate:=Current date
$modificationHeure:=Current time
End if
// créer le document décrypté temporaire; son chemin :
$fichierTempo:=Folder(Temporary folder; fk platform path).file("XYZ"+String(Random)+$TypeDoc)
BLOB TO DOCUMENT($fichierTempo.platformPath; $docOrigine)
SET DOCUMENT PROPERTIES($fichierTempo.platformPath; False; False; $modificationDate; $modificationHeure; $modificationDate; $modificationHeure)
// créer le document définitif : plusieurs cas
Case of
: ($destination=Null)
// on met le fichier du bon type à côté de l'original
$fichierDéCrypté:=$fichierTempo.copyTo($fichier.parent; $fichier.name+$TypeDoc; fk overwrite)
: ($destination.isFolder)
// on met le fichier du bon type dans $2
$fichierDéCrypté:=$fichierTempo.copyTo($destination; $fichier.name+$TypeDoc; fk overwrite)
: ($destination.isFile)
// le chemin (le type du fichier...) est imposé
// remarque : si le fichier n'est pas forcément du bon type (.xtemp), il peut être lu par certains logiciels (GraphicConverter)
$fichierDéCrypté:=$fichierTempo.copyTo($destination.parent; $fichier.name+$TypeDoc; fk overwrite)
End case
// nettoyer supprimer le fichier temporaire
$fichierTempo.delete()
If ($result.Error=0)
// renvoyer le fichier
$result.fichier:=$fichierDéCrypté
// nettoyer le fichier crypté
$fichier.delete()
End if
$result.Error:=-15019*Num(Not($fichierDéCrypté.exists)) // erreur de décryptage
$result.ErrorDescription:="échec de l'enregistrement du fichier "
End if
End if
$result.FixerSuccess()
// l'erreur est levée par l'appelant
Function LireCleCryptage($ptrBlob : Pointer; $params : Object)->$erreur : cs.Traces
//******************
// ID des clés de cryptage :
// -15001 : cryptage des medias sur l'hébergeur
// 15007 : cryptage des licences de l'application autonome
//******************
// $1 : ptrClé, $2.trousseau, .groupID {.chemin du fichier}
// doit s'exécuter sur le poste client
var $structureDeDonnées; $texte1; $texte2 : Text
var $fichier : 4D.File
$erreur:=cs.Traces.new().CréerErreur("SDK"; 0; Current method name; "")
// fixer le chemin des clés demandées
$fichier:=This.OuvrirTrousseau($params)
If ($fichier#Null)
// le test de $2 est fait : on peut y aller
SET BLOB SIZE($ptrBlob->; 0) // raz
$structureDeDonnées:=""
$erreur.Error:=This.XML.LireFichier($fichier; ->$structureDeDonnées).Error
$erreur.Error:=This.XML.LireLeChemin(->$structureDeDonnées; $params.trousseau+"/group"+String($params.groupID); $ptrBlob).Error
$erreur.Error:=-15016*Num($erreur.Error#0) // erreur lecture de clé
$texte1:=Localized string("1017")
$texte2:=String($params.trousseau)
$erreur.ErrorDescription:="La "+$texte1+": du groupe familial "+$texte2+" n'est pas disponible"
End if
$erreur.ErrorLabel:=Localized string(String($erreur.Error))
$erreur.LeverException([msgk_log])
Function OuvrirTrousseau($params : Object)->$result : 4D.File
// renvoie le chemin du trousseau de clés
// $1 : ptrClé, $params.trousseau, .groupID {.chemin du fichier}
var $dossier : 4D.Folder
var $erreur : cs.Traces
var $texte1 : Text
var $options : Collection
$dossier:=Null
$erreur:=cs.Traces.new().CréerErreur("SDK"; -15068; Current method name; "")
// accéder au trousseau
Case of
: (Not(OB Is defined($params; "trousseau")))
$erreur.ErrorDescription:="'trousseau' (private ou public) non renseigné dans $2"
: (Not(OB Is defined($params; "groupID")))
$erreur.ErrorDescription:="'groupID' non renseigné dans $2"
Else
// on peut commencer
$erreur.Error:=0
Case of
: (OB Is defined($params; "chemin"))
$dossier:=Folder($params.chemin; fk platform path)
// pour la suite, texte1 est utilisé par les "Message utilisateur"
$texte1:=Localized string("1016")+".xml"
: ($params.trousseau="@private@")
// v10.1.2 en ressource de la base hôte
$dossier:=Folder(fk resources folder; *)
// pour la suite, texte1 est utilisé par les "Message utilisateur"
$texte1:=Localized string("1016")+".xml"
: ($params.trousseau="@public@")
// en ressource du composant SDK
$dossier:=Folder(fk resources folder)
// pour la suite, texte1 est utilisé par les "Message utilisateur"
$texte1:=Localized string("1017")+".xml"
Else
$erreur.Error:=-15068
$erreur.ErrorDescription:="le paramètre $2 est incomplet"
End case
End case
$options:=[msgk_log]
Case of
: ($erreur.Error#0)
: (($dossier=Null) | (Not($dossier.exists)))
$erreur.Error:=-15015 // erreur dossier non trouvé
$erreur.ErrorDescription:="Le dossier du trousseau de clés "+$dossier.platformPath+" n'existe pas"
$options:=[msgk_log; msgk_event; msgk_user]
Else
$result:=$dossier.file($texte1)
End case
// renvoyer le résultat
Case of
: ($erreur.Error#0)
// erreur renseignée
$result:=Null
: ($result.exists)
// c'est ok
Else
$result:=Null
$erreur.Error:=-15015 // erreur fichier non trouvé
$erreur.ErrorDescription:="Le trousseau de clés "+$texte1+" n'existe pas"
$options:=[msgk_log; msgk_event; msgk_user]
End case
$erreur.ErrorLabel:=Localized string(String($erreur.Error))
$erreur.LeverException($options)
//--------------------
//MARK:Traitement
//--------------------
Function Filigraner($document : Object; $texte : Text; $positionX : Integer; $positionY : Integer; $orientation : Real; $couleurAP : Text)->$result : cs.Traces
// Ajouter au fichier $1 le filigrane $text
// en position en x $positionX, position en y $positionY, orientation $orientation, couleur fond $couleurFond
// retour dans $1
var $fichier; $dossierTravail : Object
var $racineXML; $ElémentXML : Text
var $pict : Picture
var $width; $height; $i; $nbrPages : Integer
var $zoom : Real
var $dateModificationSource : Date
var $heureModificationSource : Time
$result:=cs.Traces.new().CréerErreur("SDK"; -15068; Current method name; "")
Case of
: (Not(OB Is defined($document; "fichier")))
$result.ErrorDescription:="$1.fichier n'est pas défini"
: (Not(OB Is defined($document; "type")))
$result.ErrorDescription:="$1.type n'est pas défini"
: (Not($document.fichier.isFile))
$result.Error:=-15043
$result.ErrorDescription:="$1.fichier n'est pas un 4D.file existant"
Else
// c'est ok
// fixer les paramètres
// lire le filigrane
If ($texte="")
cs.ResourceALV.me.SetVariable(Est Ressource APP; "Ressources_Communes/Nom_Application"; Is text; ->$texte)
End if
If ($texte="")
$texte:="filigrane absent"
End if
// fixer les paramètres
If ($positionX<0)
$positionX:=0 //position x par défaut
End if
If ($positionY<0)
$positionY:=0 //position y par défaut
End if
If (($orientation<-0) | ($orientation>360))
$orientation:=0*Radian // orientation par défaut
End if
Case of
// une image
: ($document.type=1)
// filigraner l'image et l'enregistrer dans $document
// lire les propriétés de l'image
READ PICTURE FILE($document.fichier.platformPath; $pict)
PICTURE PROPERTIES($pict; $width; $height)
// créer le document SVG :
// fixer les dimensions du document
$racineXML:=This.XML.CréerArbreSVG($width; $height)
// ajouter le lien à l'image
$ElémentXML:=This.XML.AjouterImage($racineXML; $document.fichier.platformPath) //; 0; 0; $width; $height)
// ajouter le filigrane à la position calculée
$ElémentXML:=This.XML.AjouterTexte($racineXML; $positionX; $positionY; $texte; 32; "#000000"; $couleurAP)
// transformer en textArea pour gérer les débordements de texte
DOM SET XML ELEMENT NAME($ElémentXML; "textArea")
DOM SET XML ATTRIBUTE($ElémentXML; "width"; String($width-20); "height"; String($height-20))
This.XML.AjouterTransform($ElémentXML; "rotate"; [$orientation; $positionX+32; $positionY+64])
// fixer l'opacité du texte
DOM SET XML ATTRIBUTE($ElémentXML; "font-family"; "Apple Chancery"; "fill-opacity"; "0.2"; "stroke-opacity"; "1.0")
// créer l'image
SVG EXPORT TO PICTURE($racineXML; $pict; Get XML data source)
// DOM EXPORTER VERS FICHIER($racineXML;$document.fichier.parent.platformPath+"text.xml") // pour test
WRITE PICTURE FILE($document.fichier.platformPath; $pict)
DOM CLOSE XML($RacineXML)
// erreurs non gérées
$result.Error:=0
// un PDF
: ($document.type=2)
// créer un dossier des différentes pages filigranées du document
$dossierTravail:=Folder(Temporary folder; fk platform path).file("tempo_PDF"+String(Random))
// rappel : il faut des chemins POSIX
$result.Error:=Proprietes_PDF($document.fichier.path; $width; $height; $nbrPages; $i)
If ($result.Error=0)
// ajouter toutes les pages filigranées
ARRAY TEXT($Pages; 0)
$zoom:=1
For ($i; 1; $nbrPages)
// lire l'image de la page $i, enregistrée dans $fichier
// rappel : il faut des chemins POSIX
$fichier:=File($dossierTravail.path+String($i)+".png"; fk posix path)
$result.Error:=Convertir_PagePDF_dansFichier($document.fichier.path; $i; $zoom; $fichier.path)
If ($result.Error=0)
This.Filigraner(New object("fichier"; $fichier; "type"; 1); $texte; $positionX; $positionY; $orientation; $couleurAP)
APPEND TO ARRAY($Pages; $fichier.path)
End if
End for
// créer le PDF filigrané sous $document
If (Size of array($Pages)=$nbrPages)
// on n'a pas perdu de pages en route!
// récupérer l'horodatage de la création du fichier
$dateModificationSource:=$document.fichier.creationDate
$heureModificationSource:=$document.fichier.creationTime
// rappel : il faut des chemins POSIX
$result.Error:=Creer_PDF_multiPages($Pages; $document.fichier.path)
// remettre l'horodatage de la création du fichier
SET DOCUMENT PROPERTIES($document.fichier.platformPath; False; False; $dateModificationSource; $heureModificationSource; Current date; Current time)
Else
// générer une erreur (par la méthode d'erreur courante)
$result.Error:=15102
$result.ErrorDescription:="Erreur de création d'une page image du PDF "+$document.fichier.platformPath
End if
// nettoyer
$dossierTravail.delete(Delete with contents)
End if
Else
// fichier non traité
$result.Error:=Type de fichier media inconnu
$result.ErrorDescription:="$1;type n'a pas la valeur 1 ou 2"
End case
End case
$result.ErrorLabel:=Localized string(String($result.Error))
$result.LeverException([msgk_log])
//--------------------
//MARK:XML
//--------------------
Function NettoyerXML($cheminFichier : Text)
var $dataTexte : Text
$dataTexte:=Document to text($cheminFichier)
$dataTexte:=Replace string($dataTexte; Char(Carriage return)+" "+Char(Carriage return)+" "; "")
TEXT TO DOCUMENT($cheminFichier; $dataTexte)
⇧
[class]EvenementsALV - 10/05/2026 18:52:23
// gestion d'une pile d'évènements (similaire à ENREGISTRER EVENEMENT)
// historique v5.7.6 : le débit des messages du composant ALV-Arbre est trop élevé : avec ENREGISTRER EVENEMENT la console OSX les refuse (plus de 150 messages par seconde!)
property functionID; nomOBJ : Text
property EvenementsAPP_logSélectionné; EvenementsWEB_logSélectionné; cadence : Integer
singleton Class constructor($params : Object)
var $attribut : Text
For each ($attribut; OB Keys($params))
This[$attribut]:=$params[$attribut]
End for each
// on mémorise le numéro de ligne sélectionné
This.EvenementsAPP_logSélectionné:=-1
This.EvenementsWEB_logSélectionné:=-1
Function InitProcess()
// initialisation thread-safe
ON ERR CALL(Formula(traceHandler).source; ek local)
This._InitialiserListe()
// ----------------------
// MARK:Exécution dans Worker
// ----------------------
// functions de gestion du tableau des ALVlogs
// ici, on doit TOUJOURS être dans le worker "Worker EvenementsALV" ( => n'est PAS thread-safe)
Function AjouterAliste($evenement : Object)
Case of
: (Current process name#Worker EvenementsALV)
// on doit être dans le worker
CALL WORKER(Worker EvenementsALV; Formula from string("cs.EvenementsALV.me.AjouterAliste($1)"); $evenement)
: (This._InitialiserListe())
// pb d'initialisation
Else
// ajouter un evenement à la liste affichée
APPEND TO ARRAY(evenementsALV; OB Copy($evenement))
// limiter la liste
If (Size of array(evenementsALV)>params.nbrMaxLogs)
DELETE FROM ARRAY(evenementsALV; 1; Size of array(evenementsALV)-params.nbrMaxLogs)
End if
End case
Function LireListe($signal : 4D.Signal)
// renvoyer dans le signal les données du worker
var $data; $dataCopy : Object
$data:=New object()
$data.params:=OB Copy(params)
OB SET ARRAY($data; "evenementsALV"; evenementsALV)
$dataCopy:=OB Copy($data; ck shared; $signal)
Use ($signal)
$signal.result:=$dataCopy
End use
$signal.trigger()
Function _InitialiserListe()->$result : Boolean
// initialisation de la console dans le worker
// appel interne toujours
var params : Object
If (params=Null)
ARRAY OBJECT(evenementsALV; 0)
params:=New object
params.nbrMaxLogs:=Choose(cs.EnvironnementALV.new().estServeur(); 5000; 1000)
End if
$result:=False // jamais d'erreur
// ----------------------
// MARK:Editeur Evenements
// ----------------------
Function AfficherEditeur($data : Object)
var $numProc : Integer
var $nomProc : Text
// num du process (0 si pas créé)
$nomProc:="U_Formulaire?"+$data.wndTitre
$numProc:=Process number($nomProc)
Case of
: (Not(OB Is defined($data; "sourceLogs")))
: (Not(OB Is defined($data; "wndTitre")))
: ($numProc>0)
// le process existe
Else
// ok on a tout !
$data.functionID:="_AfficherEditeur_process"
$data.nomProcess:=$nomProc
$data.nomTache:="$SYS_"+$nomProc
$data.numProcessAppelant:=-1
$numProc:=Exécuter Function Coopérative(cs.EvenementsALV; $data)
End case
Function _AfficherEditeur_process($params : Object)
var $wndNum : Integer
var $data : Object
// ouvrir la fenêtre
$wndNum:=Open form window("Console"; -(Palette window); On the right; At the top; *)
SET WINDOW TITLE($params.wndTitre)
// afficher la console
$data:=cs.EvenementsALV.new()
cs.Outils.me.CopierAttributs($params; $data)
DIALOG("Console"; $data)
CLOSE WINDOW
Function AfficherDeClient()
// ici lire dans le WK la mémoire des evenements
var $nombreLignes : Integer
var $signal : 4D.Signal
// mémoriser la taille actuelle
$nombreLignes:=Size of array(evenementsALV)
// lire l'état courant
$signal:=New signal("Requete WorkerEvents")
CALL WORKER(Worker EvenementsALV; Formula from string("cs.EvenementsALV.new().LireListe($1)"); $signal)
// patienter 1 seconde au maximum
If ($signal.wait(1))
params:=$signal.result.params
OB GET ARRAY($signal.result; "evenementsALV"; evenementsALV)
End if
If (Size of array(evenementsALV)>$nombreLignes)
// de nouveaux logs ont été ajoutés, les afficher
This._CréerAffichage()
// visualiser le dernier ajout
This._FaireDéfiler("EvenementsAPP")
End if
Function AfficherDeServeur()
// ici on est sur la base hôte
var $data : Object
// interroger le serveur
$data:=New object
Storage.Host.RequeteHTTP.call(Null).Requeter("/4DHTTP/xSDK/EvenementsALV/GetEvenementsServeur"; "GET"; $data; "blob")
params:=$data.reqRetour.params
OB GET ARRAY($data.reqRetour; "evenementsALV"; evenementsALV)
// les afficher
This._CréerAffichage()
// visualiser le dernier ajout
This._FaireDéfiler("EvenementsAPP")
This._FaireDéfiler("EvenementsWEB")
Function GetEvenementsServeur($params : Object)
// ici on est sur le serveur
var $signal : 4D.Signal
$signal:=New signal("RequeteClient WorkerEvents")
CALL WORKER(Worker EvenementsALV; Formula from string("cs.EvenementsALV.new().LireListe($1)"); $signal)
// patienter 1 seconde au maximum
If ($signal.wait(1))
$params.params:=$signal.result.params
ARRAY OBJECT($evenementsALV; 0)
OB GET ARRAY($signal.result; "evenementsALV"; $evenementsALV)
OB SET ARRAY($params; "evenementsALV"; $evenementsALV)
End if
Function _CréerAffichage()
// initialiser l'affichage du tableau evenementsALV
var $i : Integer
Form.EvenementsAPP:=New collection
Form.EvenementsWEB:=New collection
For ($i; 1; Size of array(evenementsALV))
Form._AjouterEvenement(evenementsALV{$i})
End for
// remettre la sélection (si existe)
LISTBOX SELECT ROW(*; "EvenementsAPP"; Form.EvenementsAPP_logSélectionné; lk replace selection)
LISTBOX SELECT ROW(*; "EvenementsAPP"; Form.EvenementsWEB_logSélectionné; lk replace selection)
SET WINDOW TITLE(Form.wndTitre+" - "+String(Size of array(evenementsALV))+" log"+("s"*Num(Size of array(evenementsALV)>1))+" / "+String(params.nbrMaxLogs)+" - Cadence "+String(Form.cadence/60)+" secondes")
Function _AjouterEvenement($evenement : Object)
// ajouter $evenement à la (bonne) liste
var $data : Object
// s'approprier l'objet
$data:=OB Copy($evenement)
Case of
: (Not(OB Is defined($data; "horodate")))
: (Not(OB Is defined($data; "Origine")))
: (Not(OB Is defined($data; "Libellé")))
: (Not(OB Is defined($data; "Source")))
: (Not(OB Is defined($data; "Description")))
: (Not(OB Is defined($data; "Contexte")))
: (Not(OB Is defined($data.Contexte; "nomProcess")))
: (Not(OB Is defined($data.Contexte; "numProcess")))
Else
// c'est ok
// mémoriser le log dans la console
// traiter les données
$data.horodate:=Replace string(Replace string($data.horodate; "T"; " "); "Z"; " ")
$data.process:="P_"+String($data.Contexte.numProcess; "0#")+" "+$data.Contexte.nomProcess
// afficher le log
Case of
: ($data.Origine="WEB")
Form.EvenementsWEB.push($data)
Else
Form.EvenementsAPP.push($data)
End case
// limiter la taille de la liste
If (Form.EvenementsAPP.length>params.nbrMaxLogs)
Form.EvenementsAPP.remove(0; Form.EvenementsAPP.length-params.nbrMaxLogs)
End if
End case
Function _FaireDéfiler($nomListBox : Text)
// lire la ligne sélectionnée de cette LB
var $gauche; $haut; $droite; $bas; $nombreLignes : Integer
If (Form[$nomListBox+"_logSélectionné"]=-1)
// pas de sélection courante ; faire défiler la liste jusqu'en bas
OBJECT GET COORDINATES(*; $nomListBox; $gauche; $haut; $droite; $bas)
$nombreLignes:=Int(($bas-$haut-LISTBOX Get headers height(*; $nomListBox))/LISTBOX Get rows height(*; $nomListBox))
$nombreLignes:=Form[$nomListBox].length-$nombreLignes+1
OBJECT SET SCROLL POSITION(*; $nomListBox; $nombreLignes; *)
End if
// ----------------------
// MARK:Evenement FORM
// ----------------------
Function _TraiterFORMevent()
If (OB Is defined(FORM Event; "objectName"))
// event d'un objet formulaire
This.functionID:="_fct_"+FORM Event.objectName
This.nomOBJ:=FORM Event.objectName
Else
// event du formulaire
This.functionID:="_fct_Formulaire"
This.nomOBJ:=""
End if
If (OB Is defined(This; This.functionID))
This[This.functionID]()
End if
Function _fct_Formulaire()
var $gauche; $haut; $droite; $bas; $hauteur; $nombreLignes : Integer
var $Error; $cadence : Integer
var $fichier : 4D.File
Case of
: (Form event code=On Load)
ARRAY OBJECT(evenementsALV; 0)
$fichier:=Folder(fk resources folder).file("DataSDK.xml")
$cadence:=0
Case of
: (Form.sourceLogs=ALV Serveur APP)
cs.XML.me.LireLeChemin(->$fichier; "Console/cadence_serveur"; ->$cadence)
Else
cs.XML.me.LireLeChemin(->$fichier; "Console/cadence_client"; ->$cadence)
End case
This.cadence:=Choose($Error=0; $cadence; 60)
SET TIMER(This.cadence)
: (Form event code=On Timer)
// lire les logs courants
Case of
: (Form.sourceLogs=ALV Serveur APP)
// interroger le serveur
Form.AfficherDeServeur()
Else
// lire les données locales
Form.AfficherDeClient()
End case
End case
Case of
: ((Form event code=On Load) | (Form event code=On Resize))
// ajuster la hauteur de la liste à un nombre entier de lignes
OBJECT GET COORDINATES(*; "EvenementsAPP"; $gauche; $haut; $droite; $bas)
//nombre de lignes optimales
$hauteur:=$bas-$haut-LISTBOX Get headers height(*; "EvenementsAPP")
$nombreLignes:=Int(($hauteur)/LISTBOX Get rows height(*; "EvenementsAPP"))
// hauteur fenêtre
$hauteur:=$haut+LISTBOX Get headers height(*; "EvenementsAPP")+($nombreLignes*LISTBOX Get rows height(*; "EvenementsAPP"))
// corriger la taille de la fenetre
GET WINDOW RECT($gauche; $haut; $droite; $bas)
End case
Function _fct_EvenementsWEB()
This._eventsListBox("EvenementsWEB")
Function _fct_EvenementsAPP()
This._eventsListBox("EvenementsAPP")
Function _eventsListBox($varName : Text)
Case of
: (Form event code=On Clicked)
Form._surClicLigne($varName)
: (Form event code=On Mouse Enter)
// l'infobulle doit s'afficher rapidement
SET DATABASE PARAMETER(Tips delay; 1)
: (Form event code=On Mouse Move)
Form._surSurvolLigne($varName)
: (Form event code=On Mouse Leave)
//Retour délai normal
SET DATABASE PARAMETER(Tips delay; 3)
End case
Function _surSurvolLigne($nomListBox : Text)
var $mouseX; $mouseY : Real
var $j; $i; $mouseZ : Integer
var $texte : Text
var $data : Object
//#1 : trouver quelle ligne est survolée
MOUSE POSITION($mouseX; $mouseY; $mouseZ)
LISTBOX GET CELL POSITION(*; $nomListBox; $mouseX; $mouseY; $j; $i) // colonne $j, numéro de ligne $i
//#2 : définir l'infobulle à afficher
If ($i#0)
// données de la ligne survolée
$data:=Form[$nomListBox][$i-1]
$texte:=$data.Origine+" "+$data.horodate+"."+$data.process+"."+$data.Source+" : "+$data.Libellé+", "+$data.Description
OBJECT SET HELP TIP(*; $nomListBox; $texte)
// la description complète sera utilisée comme message d'aide lorsque (si) la souris est immobile
End if
Function _surClicLigne($nomListBox : Text)
var $attribut : Text
var $itemPos : Integer
// position du log sélectionné courant
$itemPos:=Form[$nomListBox+"positionElementCourant"]
// dernière position sélectionnée
$attribut:=$nomListBox+"_logSélectionné"
Case of
: (Form[$attribut]=0)
// une sélection : mémoriser qu'une sélection existe
Form[$attribut]:=$itemPos
: (Form[$attribut]#$itemPos)
// mémoriser la nouvelle ligne
Form[$attribut]:=$itemPos
Else
// la ligne '$nomListBox' est sélectionnée : la désélectionner
Form[$attribut]:=-1
LISTBOX SELECT ROW(*; $nomListBox; $itemPos; lk remove from selection)
End case
⇧
[class]Traces - 02/07/2026 14:19:07
property Origine : Text
property Error : Integer
property ErrorDescription : Text
property Source : Text
property ErrorLabel : Text
property Contexte : Object
property success : Boolean
property Description; Libellé; horodate : Text
property heure : Time
property typeApplication : Integer
// propriétés spécifiques des functions utilisatrices de cs.Traces
property fichier : 4D.File
property rapport : Collection
Class constructor($params : Object)
If (Count parameters>0)
cs.Outils.me.CopierAttributs($params; This)
End if
// ----------------------
// MARK:Erreur : process générateur
// ----------------------
// ici on est dans le process ayant généré l'erreur
Function CréerErreur($origine : Text; $Error : Integer; $nomMethode : Text; $ErrorDescription : Text)->$result : cs.Traces
This.Origine:=$origine
This.Error:=$Error
This.ErrorDescription:=$ErrorDescription
This.Source:=$nomMethode
This.Contexte:=New object
This.FixerSuccess()
// pour le chainage des functions
$result:=This
Function Intercepter($origine : Text; $Error : Integer; $Error_method : Text; $Error_line : Integer; $Error_formula : Text)->$result : Integer
var $erreur : cs.Traces
var $c : Collection
var $lastError : Object
$c:=Last errors
// mémoriser l'erreur pour traitement par la méthode
$result:=$Error
// cas des erreurs -1 (SQL)
Case of
: ($result#-1)
: ($c.length=0)
Else
$result:=$c[0].errCode
End case
$erreur:=This.CréerErreur($origine; $Error; $Error_method+" ligne "+String($Error_line); $Error_formula)
$erreur.Contexte:=New object("erreurNum"; $result; "methodeErreurs"; Method called on error)
For each ($lastError; $c)
$erreur.ErrorDescription:=$erreur.ErrorDescription+" - Erreur "+String($lastError.errCode)+" "+$lastError.message+" "+$lastError.componentSignature
End for each
$erreur.ErrorLabel:="Erreur 4Dimension™"
$erreur.LeverException([msgk_event; msgk_log])
Function LeverException($options : Collection)
// ici on est toujours dans le process de l'erreur
This._HoroDater()
This.FixerSuccess()
This.FixerOptions($options)
If (This._aTraiter())
// pour le traitement local de l'erreur
ErrorNum:=This.Error
If (Not(OB Is defined(This; "Contexte")))
This.Contexte:=New object
End if
// ajouter les params process courant (levée de l'erreur)
// rappel : Mode compilé renvoie le mode compilé du composant.
This.Contexte.estCompilé:=Is compiled mode
This.Contexte.estExecuteDansHote:=Storage.System.estExecuteDansHote
This.Contexte.estExecuteDansAPP:=Storage.System.estExecuteDansAPP
This.Contexte.nomProcess:=Current process name
This.Contexte.numProcess:=Current process
// envoyer l'erreur dans la pile de traitement
// cette function doit être thread-safe => utiliser le worker pour la suite
CALL WORKER(Worker Services; Formula(traceHandler); This; "_TraiterException")
End if
Function _aTraiter()->$result : Boolean
$result:=False
Case of
: (Not(OB Is defined(This; "Error")))
: (Not(OB Is defined(This; "ErrorDescription")))
: (This.Error=0)
// pas d'erreur
// filtrer, ne pas encombrer la messagerie
// *** filtrer les erreurs SDK :
: ((This.Error=-9768) & (This.ErrorDescription="@[class]@"))
// filtrer l'erreur générée par MÉTHODE RÉSOUDRE CHEMIN sur les classes
: ((This.Error=-16003) & (This.ErrorDescription=("@"+String(Est Ressource APP)+"@")))
// erreur normal (la ressources est dans l'hôte)
// *** filtrer les erreurs composants :
: (This.Error=-9935)
// erreurs fichier XML gérées localement
: (This.Error=-10518)
// assertion fausse
: (This.Error=-10508)
// appel méthode inconnue d'un composant
: (This.Error=1006)
// option (ou ctrl) +clic
Else
// erreur à traiter
$result:=True
End case
// ----------------------
// MARK:Erreur : Worker
// ----------------------
// ici on est hors du process ayant généré l'erreur
Function _TraiterException()
// ici on n'est plus dans le process de l'erreur
// tester les paramètres
Case of
: (Not(OB Is defined(This; "Origine")))
: (Not(OB Is defined(This; "Error")))
: (Not(OB Is defined(This; "ErrorLabel")))
: (Not(OB Is defined(This; "ErrorDescription")))
: (Not(OB Is defined(This; "Source")))
: (Not(OB Is defined(This; "Contexte")))
Else
If (Not(This.Contexte.estCompilé | This.Contexte.estExecuteDansHote))
// ici développement de composant : gérer en local
TRACE
//ALERTE("Trace erreur par "+$ErrorSource+" = erreur "+Chaîne(this.Error)+" - "+$ErrorDescription)
Else
// ici base hôte ou composant exécuté en compilé
// mettre this au format message
This.Libellé:="Erreur "+String(This.Error)
This.Description:=This.ErrorLabel+((" : "+This.ErrorDescription)*Num(This.ErrorDescription#""))
This.Diffuser()
End if
End case
Function FixerOptions($options : Collection)
var $option : Integer
If (Not(OB Is defined(This; "Contexte")))
This.Contexte:=New object
End if
This.Contexte.Options:=0x0000
If ($options.length>0)
For each ($option; $options)
This.Contexte.Options:=This.Contexte.Options ?+ $option
End for each
Else
// pas normal !
TEXT TO DOCUMENT(Folder(fk home folder).folder("tempo_ALV").folder("_ALVdebug").folder("TraceSansOptions").file(Timestamp+".json").platformPath; JSON Stringify(This; *))
End if
Function FixerSuccess()
This.success:=(This.Error=0)
This.ErrorDescription:=This.ErrorDescription*(Num(Not(This.success)))
// ----------------------
// MARK:Messagerie
// ----------------------
Function _CréerMessage($origine : Text; $libellé : Text; $source : Text; $description : Text)->$result : cs.Traces
This.Origine:=$origine
This.Libellé:=$libellé
This.Source:=$source
This.Description:=$description
This.typeApplication:=Storage.System.typeApplication
This.Contexte:=New object
This.Contexte.nomProcess:=Current process name
This.Contexte.numProcess:=Current process
// pour le chainage des functions
$result:=This
Function EnvoyerMessages($options : Collection; $origine : Text; $libellé : Text; $source : Text; $description : Text; $contexte : Object)
This._CréerMessage($origine; $libellé; $source; $description)
Case of
: (Count parameters=5)
: ($contexte=Null)
Else
This.Contexte:=$contexte
End case
This.FixerOptions($options)
This._HoroDater()
This.Diffuser()
Function Diffuser()
var $params : Object
Case of
: (Not(OB Is defined(This; "Origine")))
: (Not(OB Is defined(This; "Libellé")))
: (Not(OB Is defined(This; "Source")))
: (Not(OB Is defined(This; "Description")))
: (Not(OB Is defined(This; "Contexte")))
: (Not(OB Is defined(This.Contexte; "Options")))
Else
// compléter le contexte composant
If (Not(OB Is defined(This.Contexte; "estExecuteDansHote")))
This.Contexte.estExecuteDansHote:=Storage.System.estExecuteDansHote
End if
Case of
: (Storage.System.estExecuteDansAPP)
// on est dans l'APP, lancer la messagerie complète
This._PosterMessages()
: (This.Contexte.Options ?? msgk_event)
// on est dans un composant ; transmettre uniquement l'event
// ajouter à la liste (rappel : Worker Services gère la console)
$params:=New object
cs.Outils.me.CopierAttributs(This; $params)
cs.EvenementsALV.me.AjouterAliste($params)
End case
End case
Function _PosterMessages()
// ici on est dans l'APP
var $result : Object
// les messages hors IHM sont exécutés dans un Worker
If (Current process name=Worker Services)
// ok exécuter ici
// Emettre les messages (actifs selon les options)
This._EcrireLog()
This._EnregistrerEvenement()
This._EmettreAlerte()
This._EcrireLogDebug()
// enfin les messages de type IHM
Case of
: (Process activity(Processes only).processes.query("name = :1"; Current process name)[0].preemptive)
// pas candidat aux autres messages
Else
// 4D 20R7 $result et null impératifs
$result:=Storage.Host.Trace.call(Null).PosterMessagesIHM(OB Copy(This))
End case
Else
// lancer la tache dans le worker
CALL WORKER(Worker Services; Formula(traceHandler); This; "_PosterMessages")
End if
Function _HoroDater()
// fixer date et heure du message
This.horodate:=Timestamp
This.heure:=Current time
Function _EcrireLog()
// v11.0.14 les log sont stockes dans une collection, purgée dans le fichier toutes les secondes
var $texte : Text
var $c : Collection
Case of
: (Not((This.Contexte.Options ?? msgk_log) | (This.Contexte.Options ?? msgk_instal)))
: (Current process name#Worker Services)
Else
If (Not(OB Is defined(Storage.TraceLogs; "Logs")))
// initialiser la collection de logs
Use (Storage.TraceLogs)
Storage.TraceLogs.Date:=String(Current date; ISO date; Current time)
Storage.TraceLogs.Logs:=New shared collection
End use
End if
// stocker
This.horodate:=Replace string(Replace string(This.horodate; "T"; "_"); "Z"; "")
$c:=New shared collection(OB Copy(This; ck shared)).copy(ck shared; Storage.TraceLogs.Logs)
// $c appartient au groupe Storage.System.TraceLogs.Logs
Use (Storage.TraceLogs.Logs)
Storage.TraceLogs.Logs.combine($c)
End use
// prochaine écriture (10 s apres la création de la collection)
// v11.0.14 avec une durée de 1 s, les premiers logs à linstallation du serveur APP sont enregistrés dans un fichier du dossier /bib/Application support/ALV
// pourquoi?
$texte:=String(Date(Storage.TraceLogs.Date); ISO date; Time(Time(Storage.TraceLogs.Date)+10))
Case of
: (Storage.TraceLogs.Logs.length=0)
: (String(Current date; ISO date; Current time)<$texte)
Else
This._EnregistrerLogs()
End case
End case
Function _EnregistrerLogs()
var $c : Collection
If (Storage.TraceLogs.Logs.length>0)
// récupérer la collection de logs
Use (Storage.TraceLogs)
$c:=New collection
$c.combine(Storage.TraceLogs.Logs)
// vider
Storage.TraceLogs.Logs:=New shared collection
Storage.TraceLogs.Date:=String(Current date; ISO date; Current time)
End use
This._EcrireLogs($c; This.GetMessagesFichier(); msgk_log)
This._EcrireLogs($c; This.GetMessagesInstallFichier(); msgk_instal)
End if
Function _EcrireLogs($c : Collection; $fichier : 4D.File; $msgk : Integer)
// envoyer la collection de logs $c dans le fichier $fichier
var $handle : 4D.FileHandle
var $texte : Text
var $log : Object
$handle:=$fichier.open(New object("mode"; "append"; "charset"; "UTF-8"; "breakModeWrite"; Document with CR))
Case of
: ($c.length=0)
: ($handle=Null)
Else
$texte:=""
// entête du fichier
If ($handle.getSize()=0)
$texte:="Créé le "+String(Current date)+", à "+String(Current time)+Char(Carriage return)+Char(Carriage return)
End if
For each ($log; $c)
If ($log.Contexte.Options ?? $msgk)
// écrire '.horodate', '.Libellé', .Source' et '.Description' dans le fichier Log
$texte:=$texte+$log.Origine+Char(Tab)+$log.horodate+Char(Tab)+"P_"+String($log.Contexte.numProcess; "0#")+(".I"*Num(Not(Is compiled mode)))+(".C"*Num(Is compiled mode))+"_"+$log.Contexte.nomProcess+Char(Tab)+$log.Source+Char(Tab)+$log.Libellé+Char(Tab)+$log.Description+Char(Carriage return)
End if
End for each
$handle.writeText($texte)
End case
$handle:=Null
Function _EnregistrerEvenement()
If (This.Contexte.Options ?? msgk_event)
// message vers la console (équivalent de la commande 4D ENREGISTRER ÉVÉNEMENT)
cs.EvenementsALV.me.AjouterAliste(OB Copy(This))
End if
Function _EmettreAlerte()
// message hard !
If (This.Contexte.Options ?? msgk_alerte)
BEEP
If (Not(Is compiled mode))
// crispant
//ALERTE(JSON Stringify($data))
//ALERTE("4Dimension™ trace erreur par "+$data.sourceLog+" = "+$data.libelléLog+" - "+$data.descriptionLog)
End if
End if
Function _EcrireLogDebug()
// écrire le message dans un fichier debug
var $texte; $fichier : Text
If (This.Contexte.Options ?? msgk_debug)
$texte:=Split string(This.Libellé; Folder separator; sk trim spaces+sk ignore empty strings).join("/"; ck ignore null or empty)
$texte:="_"+This.Origine+"debug/"+$texte
$fichier:=This.GetGarbageDossier().folder($texte).file(This.Source+".txt").platformPath
// ajouter la description au fichier
$texte:=""
If (Test path name($fichier)=Is a document)
$texte:=Document to text($fichier; "UTF-8"; Document with native format)
$texte:=$texte+Char(Line feed)
End if
$texte:=$texte+This.Description
TEXT TO DOCUMENT($fichier; $texte; "UTF-8"; Document with native format)
End if
// ----------------------
// MARK:Trace DEBUG
// ----------------------
Function DebugerMethode($session : Object; $origine : Text; $libellé : Text; $source : Text; $description : Text)->$result : Boolean
// trace d'une méthode
// si l'appel à cette fonction est encapsulé dans un ASSERT, renvoyer Vrai, sinon une erreur est générée
$result:=True
If (This.estASSERTactif($session))
This._CréerMessage($origine; $libellé; $source; $description)
This._HoroDater()
This.FixerOptions([msgk_log; msgk_event])
// tagguer ASSERT
This.Libellé:="ASSERT "+This.Libellé
// activer la messagerie
CALL WORKER(Worker Services; Formula(traceHandler); This; "Diffuser")
End if
Function DebugerVariables($session : Object; $origine : Text; $libellé : Text; $source : Text; $data : Object)->$result : Boolean
// trace de variables
var $attribut : Text
var $c : Collection
// si l'appel à cette fonction est encapsulé dans un ASSERT, renvoyer Vrai, sinon une erreur est générée
$result:=True
If (This.estASSERTactif($session))
This._CréerMessage($origine; $libellé; $source; "")
This._HoroDater()
This.FixerOptions([msgk_log; msgk_event])
// tagguer ASSERT
This.Libellé:="ASSERT "+This.Libellé
Case of
: ($data=Null)
: ($data.length=0)
Else
// ok$
$c:=New collection
For each ($attribut; OB Keys($data))
Case of
: (Value type($data[$attribut])=Is text)
$c.push($attribut+" = "+$data[$attribut])
: (Value type($data[$attribut])=Is boolean)
$c.push($attribut+" = "+String($data[$attribut]))
: (Value type($data[$attribut])=Is longint)
$c.push($attribut+" = "+String($data[$attribut]))
: (Value type($data[$attribut])=Is real)
$c.push($attribut+" = "+String($data[$attribut]))
Else
$c.push($attribut+" = type "+String(Value type($data[$attribut]))+" non traité")
End case
End for each
This.Description:="Variables : "+$c.join(", ")
// activer la messagerie
CALL WORKER(Worker Services; Formula(traceHandler); This; "Diffuser")
End case
End if
Function DebugerEventForm($session : Object; $origine : Text; $libellé : Text; $source : Text; $data : Object)->$result : Boolean
// tracer un évènement formulaire
var $numEvent; $numTable; $typeEvent : Integer
// si l'appel à cette fonction est encapsulé dans un ASSERT, renvoyer Vrai, sinon une erreur est générée
$result:=True
If (This.estASSERTactif($session))
This._CréerMessage($origine; $libellé; $source; "")
This._HoroDater()
This.FixerOptions([msgk_log; msgk_event])
// tagguer ASSERT
This.Libellé:="ASSERT "+This.Libellé
Case of
: (Not($session.Session_Etat ?? 3))
: ($data.numEvent=Null)
: ($data.numTable=Null)
// circuler
Else
// ok
$numEvent:=$data.EventForm.numEvent
$numTable:=$data.EventForm.numTable
// navigation
$typeEvent:=1
Case of
: ($numEvent=On Load)
This.Description:="Sur chargement / Le formulaire va être affiché"
: ($numEvent=On Unload)
This.Description:="Sur libération / Le formulaire sortie vient de se fermer et va disparaître de l'écran"
: ($numEvent=On Close Box)
This.Description:="Sur case de fermeture / On a cliqué sur la case de fermeture de la fenêtre"
: ($numEvent=On Resize)
This.Description:="sur redimensionnement / La fenêtre du formulaire est redimensionnée"
: ($numEvent=On Display Detail)
This.Description:="Sur affichage corps / Affichage de l'enregistrement n°"+String(Selected record number(Table($numTable)->))
: ($numEvent=On Menu Selected)
//$MessageDescription:="Sur menu sélectionné / La commande "+Chaîne(Menu choisi & 0xFFFF)+" du menu "+Chaîne((Menu choisi & 0xFFFF0000) >> 16)+" a été sélectionnée"
: ($numEvent=On Clicked)
This.Description:="Sur clic / Un clic est survenu sur un objet"
: ($numEvent=On Double Clicked)
This.Description:="Sur double clic / On a double-cliqué sur un enregistrement"
: ($numEvent=On Open Detail)
This.Description:="Sur ouverture corps / On a double-cliqué sur l'enregistrement n°"+String(Selected record number(Table($numTable)->))
: ($numEvent=On Close Detail)
This.Description:="Sur fermeture corps / Retour au formulaire sortie"
: ($numEvent=On Activate)
This.Description:="Sur activation / La fenêtre du formulaire passe au premier plan"
: ($numEvent=On Deactivate)
This.Description:="Sur désactivation / La fenêtre du formulaire n'est plus au premier plan"
: ($numEvent=On Outside Call)
This.Description:="Sur appel extérieur / La commande extérieure <Tuer le process> a été reçue"
: ($numEvent=On Plug in Area)
This.Description:="Sur appel zone du plug in / Un plug-in demande que sa méthode objet soit exécutée"
: ($numEvent=On Drag Over)
This.Description:="Sur glisser"
: ($numEvent=On Drop)
This.Description:="Sur déposer"
End case
If (Length(This.Description)=0)
// déplacement souris
$typeEvent:=2
Case of
: ($numEvent=On Mouse Enter)
This.Description:="Sur début survol / Le curseur de la souris entre dans la zone graphique d'un objet"
: ($numEvent=On Mouse Move)
This.Description:="Sur survol / Le curseur de la souris bouge"
: ($numEvent=On Mouse Leave)
This.Description:="Sur fin survol / Le curseur de la souris sort de la zone graphique d'un objet"
: ($numEvent=On Timer)
This.Description:="Sur minuteur/ Le nombre de ticks défini par FIXER MINUTEUR est atteint"
: ($numEvent=On Getting Focus)
This.Description:="Sur gain focus"
: ($numEvent=On Losing Focus)
This.Description:="Sur perte focus"
End case
End if
If (Length(This.Description)=0)
// exotic
$typeEvent:=4
Case of
: ($numEvent=On Header)
This.Description:="Sur entête / L'en-tête va être imprimé ou affiché"
Else
This.Description:="n°"+String($numEvent)+", que se passe-t-il ?"
End case
End if
End case
Case of
: (This.Description="")
// circuler, rien à voir
: ($typeEvent=2)
// filtrer ces messages (saturent la console)
Else
// c'est ok
// tagger
This.Description:="Form Event : "+This.Description
// lancer la messagerie
CALL WORKER(Worker Services; Formula(traceHandler); This; "Diffuser")
End case
End if
Function estASSERTactif($session : Object)->$result : Boolean
$result:=False
Case of
: ($session=Null)
// peut arriver
: (Not($session.Session_Etat ?? 6))
// on n'est pas en mode debug
: (Not($session.Session_Etat ?? 8))
// on ne veut pas de traces
Else
// Assertion activée
$result:=True
End case
// -----------------------------
// Mark:Document système
// -----------------------------
Function GetMessagesFichier()->$result : 4D.File
var $texte : Text
// fixer le chemin du fichier de la messagerie
$texte:=Substring(String(Current date; ISO date); 1; 10)
$texte:=$texte+" - Run "+cs.EnvironnementALV.new().infosApplication().nomLong
$result:=Folder(fk logs folder; *).file($texte+".log.txt")
Function GetMessagesInstallFichier()->$result : 4D.File
// fixer le chemin du fichier de la messagerie d'installation
var $texte : Text
$texte:=cs.EnvironnementALV.new().infosApplication().nomLong
$result:=Folder(fk user preferences folder; *).folder(cs.EnvironnementALV.new().infosApplication().nomLong).folder("Logs").file("Install "+$texte+".log.txt")
Function GetGarbageDossier()->$result : 4D.Folder
// renvoyer le chemin du dossier temporaire de travail
$result:=Folder(fk home folder).folder("tempo_ALV")
$result.create()
⇧
[class]TraductionsEditeur - 10/05/2026 18:52:46
property environnement : cs.EnvironnementALV
property titreFenetre; nomTache; nomOBJ; functionID; sql_BDDpath; racineXML; Langue; fichier; itemText : Text
property itemRef; sousListe; MargeForm; STRidMin; STRidMax; FichierID; GroupeID; ConstanteID; itemPos : Integer
property deployee; VoletOuvert : Boolean
property NomsGroupeXLF : Object
property ListeTraductions; liste; ListeSTR : Collection
Class constructor()
This.environnement:=cs.EnvironnementALV.new()
This.titreFenetre:="Editeur de traductions"
This.nomTache:="LocalisationAPP"
This.nomOBJ:=""
This.functionID:=""
This.sql_BDDpath:=Folder(fk resources folder; *).folder("localization.4dbase").platformPath+"localization"
This.MargeForm:=10
This.VoletOuvert:=False
Function ModifierTraductions()
// exécuter dans un process externe
var $data : Object
var $numProc : Integer
$data:=New object
$data.functionID:="_AfficherLesChaineLocalisées"
$data.nomProcess:="$SYS_LocalisationAPP"
$data.nomTache:=This.nomTache
$data.numProcessAppelant:=-1
$numProc:=Exécuter Function Coopérative(cs.TraductionsEditeur; $data)
// rappel : l'objet $data.tache a été créé
//--------------------
//MARK:Formulaire
//--------------------
Function _AfficherLesChaineLocalisées($params : Object)
var $wndNum; $i : Integer
var $nomProc : Text
var $data : Object
Case of
: (This.environnement.estServeur())
: (This.environnement.estClient())
Else
// dans une base hôte, créer une fenêtre type palette dans le process courant
// par défaut il n'y a PAS de process particulier à ce composant !
// c'est à l'appelant de gérer le process appelant
// chercher la fenêtre du composant
$wndNum:=0
ARRAY LONGINT($wndList; 0)
WINDOW LIST($wndList; *)
For ($i; 1; Size of array($wndList))
If (Get window title($wndList{$i})=This.titreFenetre)
$wndNum:=$wndList{$i}
End if
End for
If ($wndNum=0)
// créer la fenêtre
NO DEFAULT TABLE
// la fenêtre est ouverte en taille normale. Le user ne peut pas modifier la taille
$nomProc:="U_Palette?3050"
$data:=cs.TraductionsEditeur.new()
cs.Outils.me.CopierAttributs($params; $data)
$wndNum:=Open form window($nomProc; Palette form window; Horizontally centered; Vertically centered; *)
SET WINDOW TITLE(This.titreFenetre; $wndNum)
DIALOG($nomProc; $data)
End if
End case
Function _AfficherLesTraductions()
var $ID; $i : Integer
Case of
: (Form.ListeChaines.length=0)
: (Form.ListeChainesPositionElementCourant<1)
: (Form.ListeChainesPositionElementCourant>Form.ListeChaines.length)
Else
Form.ListeChainesElementCourant:=Form.ListeChaines[Form.ListeChainesPositionElementCourant-1]
// afficher les infos de la ressource sélectionnée tabID{tabID}
Form.SaisieSTRid:=Form.ListeChainesElementCourant.STRid
Form.SaisieSTRgroup:=Form.ListeChainesElementCourant.STRgroupe
// lire les traductions disponibles de la ressource sélectionnée
ARRAY TEXT($tabTraductions; 0)
ARRAY TEXT($tabLangues; 0)
$ID:=Form.ListeChainesElementCourant.ID
This._OuvrirBDD()
Begin SQL
SELECT localizedSTR.libelle, localizedSTR.langue
FROM localizedSTR
WHERE localizedSTR.STRid = :$ID
INTO :$tabTraductions, :$tabLangues;
End SQL
// trier les traductions par langue (actuellement le sens inverse place 'fr' en premier)
SORT ARRAY($tabLangues; $tabTraductions; <)
// fixer les icones des langues
ARRAY PICTURE($tabIcones; Size of array($tabLangues))
// v19 les icones sont en ressources, sous le code langue ; les langues sont conformes à la norme ISO639-1
For ($i; 1; Size of array($tabLangues))
READ PICTURE FILE(Folder(fk resources folder).folder("Images").file($tabLangues{$i}+".png").platformPath; $tabIcones{$i})
End for
// passer dans l'affichage
Form.ListeTraductions:=New collection
ARRAY TO COLLECTION(This.ListeTraductions; $tabIcones; "Icone"; $tabTraductions; "Traduction"; $tabLangues; "Langue")
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
End case
Function _AfficherConstante()
Case of
: (Form.itemRef=0)
: (This.itemRef<100)
// on a cliqué sur un fichier
This._FichierNom()
: (This.itemRef<10000)
// on a cliqué sur un groupe
This._GroupeNom()
// rafraichir le nom du fichier
This.itemRef:=List item parent(LHdesItems; This.itemRef)
This._FichierNom()
: (This.itemRef<1000000)
// on a une constante
This._ConstanteNom()
This._ConstanteValeur()
This._ConstanteType()
// rafraichier le nom du groupe
This.itemRef:=List item parent(LHdesItems; This.itemRef)
This._GroupeNom()
// rafraichier le nom du fichier
This.itemRef:=List item parent(LHdesItems; This.itemRef)
This._FichierNom()
Else
End case
Function _FichierNom()
Form.FichierNom:=This._LireParametreLH_text("nom")
Form.FichierID:=This._LireParametreLH_int("id")
Function _GroupeNom()
Form.GroupeID:=This._LireParametreLH_int("d4:groupID")
Form.GroupeTypeRessource:=This._LireParametreLH_text("restype")
Form.GroupeNom:=This._LireParametreLH_text("d4:groupName")
Function _ConstanteNom()
Form.ConstanteNom:=This._LireParametreLH_text("nom")
Form.ConstanteID:=This._LireParametreLH_int("constanteID")
Function _ConstanteValeur()
Form.ConstanteValeur:=This._LireParametreLH_text("d4:value")
Function _ConstanteType()
var $typeConstante : Text
$typeConstante:=This._LireParametreLH_text("restype")
Form["ConstanteType"].index:=Form["ConstanteType"].constantesType.indexOf($typeConstante)
// ----------------------
//MARK:FORMevents FORM
// -----------------------
Function _TraiterFORMevent()
If (OB Is defined(FORM Event; "objectName"))
// event d'un objet formulaire
This.functionID:="_FORM_"+FORM Event.objectName
This.nomOBJ:=FORM Event.objectName
Else
// event du formulaire
This.functionID:="_FORM"
This.nomOBJ:=""
End if
If (OB Is defined(This; This.functionID))
This[This.functionID]()
End if
Function _FORM()
var $gauche; $haut; $droite; $bas; $droiteObjet; $basObjet : Integer
Case of
: (FORM Event.code=On Load)
GET WINDOW RECT($gauche; $haut; $droite; $bas; Current form window)
FORM GET PROPERTIES("U_Palette?3050"; $droiteObjet; $basObjet)
SET WINDOW RECT($gauche; $haut; $gauche+$droiteObjet; $haut+$basObjet; Current form window)
FORM SET VERTICAL RESIZING(True)
FORM SET HORIZONTAL RESIZING(True)
// masquée
FORM SET SIZE("BoutonVolet"; Form.MargeForm; Form.MargeForm)
// charger les objets
This._onEndLoad()
: (FORM Event.code=On Unload)
// appel des objets concernés
This._FORM_ModifierSTR()
This._FORM_ListeChaines()
This._FORM_ModifierXLF()
// fermer
This._FermerFORM()
End case
Function _onEndLoad()
var $c : Collection
var $functionID : Text
// en DUR pour l'instant ; dans l'ordre
$c:=["Onglet"]
$c.combine(["ModifierSTR"; "ListeChaines"; "Recherche"])
$c.combine(["ModifierXLF"; "ListeHdesFichiers"])
For each ($functionID; $c)
This.nomOBJ:=$functionID
This["_FORM_"+$functionID]()
End for each
Function _FORM_Onglet()
Case of
: (FORM Event.code=On Load)
Form[This.nomOBJ]:=New object
Form[This.nomOBJ].values:=New collection("Localisation ALV"; "Constantes ALV")
Form[This.nomOBJ].index:=0
End case
Function _FermerFORM()
CANCEL
// ----------------------
//MARK:FORMevents Page STR
// ----------------------
Function _FORM_ModifierSTR()
// afficher les STR / en ajouter
var $itemText; $texte; $STRgroupe : Text
var $c : Collection
var $IDmax : Integer:=-1
Case of
: (FORM Event.code=On Load)
// fixer le chemin de la BDD à ouvrir, installé en ressource
This._OuvrirBDD()
// afficher les traductions existantes dans la listBox
ARRAY LONGINT($tabID; 0)
ARRAY LONGINT($tabSTRid; 0)
ARRAY TEXT($tabSTRgroupe; 0)
ARRAY TEXT($tabSTRtexte; 0)
// chercher tous les textes de langue 'fr' avec leur ID de ressource (STRid) et leur ID en BDD
Begin SQL
SELECT localizedSTR.libelle, translations.id, translations.STRid, translations.nom_group
FROM localizedSTR
INNER JOIN translations ON localizedSTR.STRid = translations.id
WHERE localizedSTR.langue = 'fr'
INTO :$tabSTRtexte, :$tabID, :$tabSTRid, :$tabSTRgroupe;
End SQL
// trier les patates par ID ressource croissant
SORT ARRAY($tabSTRid; $tabSTRtexte; $tabID; $tabSTRgroupe; >)
Form.ListeChaines:=New collection
ARRAY TO COLLECTION(Form.ListeChaines; $tabSTRid; "STRid"; $tabSTRtexte; "STRtexte"; $tabID; "ID"; $tabSTRgroupe; "STRgroupe")
: (FORM Event.code=On Clicked)
var btnModifierSTR : Integer
If (Form.ListeChainesElementCourant=Null)
$STRgroupe:="Groupe 1"
Form.ListeChainesPositionElementCourant:=1
Else
// initialiser avec l'élément sélectionné
$STRgroupe:=Form.ListeChainesElementCourant.STRgroupe
End if
// créer un enregistrement [translations]. REMARQUE IMPORTANTE : id est en valeur unique auto incrémentée
This._OuvrirBDD()
Begin SQL
START TRANSACTION;
INSERT INTO translations (STRid, nom_group) VALUES (-1, :$STRgroupe);
COMMIT TRANSACTION;
SELECT MAX(id) FROM translations INTO : $IDmax;
End SQL
// créer les 4 enregistrements [localizedSTR], un par langue
// chaine par défaut
$texte:="nouvelle chaine"
$c:=cs.Outils.new().ListerLanguesApplication().codes
Begin SQL
START TRANSACTION;
End SQL
For each ($itemText; $c)
Begin SQL
INSERT INTO localizedSTR (STRid, langue, libelle) VALUES (:$IDmax, :$itemText, :$texte);
End SQL
End for each
Begin SQL
COMMIT TRANSACTION;
End SQL
This._FermerBDD()
// insérer une ligne (=> insère une ligne à $i dans les 4 tableaux)
Form.ListeChaines.insert(Form.ListeChainesPositionElementCourant-1; New object("STRid"; -1; "STRtexte"; $texte; "ID"; $IDmax; "STRgroupe"; $STRgroupe))
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
This._AfficherLesTraductions()
: (FORM Event.code=On Unload)
This._FermerBDD()
End case
Function _FORM_SupprimerSTR()
var btnSupprimerSTR : Integer
var $ID; $rang : Integer
Case of
: (FORM Event.code=On Clicked)
Case of
: (Form.ListeChainesElementCourant=Null)
: (Form.ListeChainesPositionElementCourant=0)
Else
CONFIRM("Confirmer la suppression de la chaine '"+String(Form.ListeChainesElementCourant.STRid)+"'"; "Annuler"; "Ok")
If (ok=0)
// supprimer les enregistrements [localizedSTR] de id = $ID
// supprimer un enregistrement [translations] de id = $ID
$ID:=Form.ListeChainesElementCourant.ID
This._OuvrirBDD()
Begin SQL
START TRANSACTION;
DELETE FROM localizedSTR WHERE STRid = :$ID;
DELETE FROM translations WHERE id = :$ID;
COMMIT TRANSACTION;
End SQL
// fixer la nouvelle à afficher
Case of
: (Form.ListeChainesPositionElementCourant=1)
// on a viré la première ligne, se mettre à la première
$rang:=1
: (Form.ListeChainesPositionElementCourant>Form.ListeChaines.length)
// on a viré la dernière ligne, se mettre à la dernière
$rang:=Form.ListeChaines.length
Else
// se mettre à la nouvelle ligne i
$rang:=Form.ListeChainesPositionElementCourant
End case
// supprimer de la listbox la ligne sélectionnée
Form.ListeChaines.remove(Form.ListeChainesPositionElementCourant-1)
LISTBOX SELECT ROW(*; "ListeChaines"; $rang; lk replace selection)
This._AfficherLesTraductions()
End if
End case
End case
Function _FORM_ListeChaines()
var $sélection : Collection
var $ID : Integer
Case of
: (FORM Event.code=On Load)
// afficher la première ressource
$ID:=This._LireUserPrefs("IDlocaliséSTR"; Is longint)
$sélection:=Form.ListeChaines.query("ID = :1"; $ID)
If ($sélection.length=0)
Form.ListeChainesPositionElementCourant:=1
Else
Form.ListeChainesPositionElementCourant:=Form.ListeChaines.indexOf($sélection[0])+1
End if
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
OBJECT SET SCROLL POSITION(*; "ListeChaines"; Form.ListeChainesPositionElementCourant)
: (FORM Event.code=On Unload)
This._EcrireUserPrefs("IDlocaliséSTR"; Form.ListeChainesElementCourant.ID)
End case
If ((FORM Event.code=On Load) | (FORM Event.code=On Selection Change))
This._AfficherLesTraductions()
End if
Function _FORM_SaisieSTRgroup()
var $ID : Integer
var $STRgroupe : Text
Case of
: (FORM Event.code=On Data Change)
// on a une BDD ouverte
If (Form.ListeChainesElementCourant#Null)
// mémoriser la valeur dans l'enregistrement $ID
$ID:=Form.ListeChainesElementCourant.ID
$STRgroupe:=Form.SaisieSTRgroup
This._OuvrirBDD()
Begin SQL
UPDATE translations SET nom_group = :$STRgroupe WHERE id = :$ID;
End SQL
End if
// mettre à jour la listBox
Form.ListeChainesElementCourant.STRgroupe:=$STRgroupe
// rafraichir
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
End case
Function _FORM_SaisieSTRid()
var $ID; $STRid : Integer
Case of
: (FORM Event.code=On Data Change)
// on a une BDD ouverte
If (Form.ListeChainesElementCourant#Null)
// mémoriser la valeur dans l'enregistrement $ID
$ID:=Form.ListeChainesElementCourant.ID
$STRid:=Form.SaisieSTRid
This._OuvrirBDD()
Begin SQL
UPDATE translations SET STRid = :$STRid WHERE id = :$ID;
End SQL
End if
// mettre à jour la listBox
Form.ListeChainesElementCourant.STRid:=$STRid
// rafraichir
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
End case
Function _FORM_ListeTraductions()
var $ID : Integer
var $langue; $traduction : Text
Case of
: (FORM Event.code=On Data Change)
If (Form.ListeTraductionsElementCourant#Null)
This._OuvrirBDD()
// on a une BDD ouverte
// quelle langue a-t-on modifié? $i = la ligne courante
$langue:=Form.ListeTraductionsElementCourant.Langue
// nouvelle traduction
$traduction:=Form.ListeTraductionsElementCourant.Traduction
$ID:=Form.ListeChainesElementCourant.ID
// mémoriser la valeur dans l'enregistrement ID
Begin SQL
UPDATE localizedSTR SET libelle = :$traduction WHERE STRid = :$ID AND langue = :$langue;
End SQL
End if
// si c'est la langue de référence ('fr' EN DUR) mettre à jour la listBox
If ($langue="fr")
// mettre à jour la listBox
Form.ListeChainesElementCourant.STRtexte:=$traduction
// rafraichir
LISTBOX SELECT ROW(*; "ListeChaines"; Form.ListeChainesPositionElementCourant; lk replace selection)
End if
End case
Function _FORM_BoutonVolet()
var $gauche; $haut; $droite; $bas; $gaucheObjet; $hautObjet; $droiteObjet; $basObjet : Integer
GET WINDOW RECT($gauche; $haut; $droite; $bas; Current form window)
Case of
: (FORM Event.code=On Clicked)
// mettre à jour
If (Form.VoletOuvert=True)
//contracter
OBJECT GET COORDINATES(*; "BoutonVolet"; $gaucheObjet; $hautObjet; $droiteObjet; $basObjet)
$droite:=$gauche+$droiteObjet+Form.MargeForm
$bas:=$haut+$basObjet+Form.MargeForm
SET WINDOW RECT($gauche; $haut; $droite; $bas; Current form window)
FORM SET SIZE("BoutonVolet"; Form.MargeForm; Form.MargeForm)
Else
// déployer
OBJECT GET COORDINATES(*; "ListeSTR"; $gaucheObjet; $hautObjet; $droiteObjet; $basObjet)
$droite:=$gauche+$droiteObjet+Form.MargeForm
$bas:=$haut+$basObjet+Form.MargeForm
$droiteObjet:=$droite-(Screen width-4)
If ($droiteObjet>0) // recadrer la fenêtre
$droite:=$droite-$droiteObjet
$gauche:=$gauche-$droiteObjet
End if
SET WINDOW RECT($gauche; $haut; $droite; $bas; Current form window)
FORM SET SIZE("ListeSTR"; Form.MargeForm; Form.MargeForm)
End if
Form.VoletOuvert:=Not(Form.VoletOuvert)
End case
Function _FORM_Recherche()
var $langue; $texte : Text
var $i; $ID : Integer
Case of
: (FORM Event.code=On Load)
SearchPicker SET HELP TEXT(This.nomOBJ; "%texte%")
Form.Recherche:=""
: (FORM Event.code=On Losing Focus)
// rechercher les STRid dont le libellé français contient Form.Recherche
This._OuvrirBDD()
$langue:="fr"
$texte:=Form.Recherche
ARRAY LONGINT($tabSelectSTRid; 0)
ARRAY LONGINT($tabSelectID; 0)
Begin SQL
SELECT translations.STRid, translations.id FROM translations
WHERE translations.id IN (SELECT STRid FROM localizedSTR WHERE libelle LIKE :$texte AND langue = :$langue)
INTO :$tabSelectSTRid, :$tabSelectID;
End SQL
SORT ARRAY($tabSelectSTRid; $tabSelectID; >)
// lister les libellés de ces STRid
ARRAY TEXT($tabSelectLibelle; Size of array($tabSelectSTRid))
For ($i; 1; Size of array($tabSelectSTRid))
$ID:=$tabSelectID{$i}
$texte:=""
Begin SQL
SELECT localizedSTR.libelle
FROM localizedSTR
WHERE localizedSTR.STRid = :$ID AND localizedSTR.langue = :$langue
INTO :$texte;
End SQL
$tabSelectLibelle{$i}:=$texte
End for
Form.ListeSTR:=New collection
ARRAY TO COLLECTION(This.ListeSTR; $tabSelectSTRid; "STRid"; $tabSelectLibelle; "STRtexte")
End case
Function _FORM_ListeSTR()
var $entité : Object
Case of
: (FORM Event.code=On Selection Change)
// on a une sélection
Case of
: (Form.ListeSTR.length=0)
: (Form.ListeSTRElementCourant=Null)
Else
$entité:=Form.ListeChaines.query("STRid = :1"; Form.ListeSTRElementCourant.STRid)[0]
Form.ListeChainesPositionElementCourant:=Form.ListeChaines.indexOf($entité)+1
This._AfficherLesTraductions()
End case
End case
Function _FORM_EnregistrerXLIFF()
This._OuvrirBDD()
This._EnregistrerXLIFF()
// ----------------------
//MARK:FORMevents Page XLF
// ----------------------
Function _FORM_ModifierXLF()
var $itemRef : Integer
Case of
: (FORM Event.code=On Load)
This._LireFichierXLF()
: (FORM Event.code=On Clicked)
This._AjouterXLF()
: (FORM Event.code=On Unload)
$itemRef:=Selected list items(LHdesItems; *)
This._EcrireUserPrefs("IDconstante"; $itemRef)
If (Is a list(LHdesItems))
CLEAR LIST(LHdesItems; *)
End if
End case
Function _FORM_SupprimerXLF()
var btnSupprimerXLF : Integer
var $itemRef : Integer
var $itemText : Text
Case of
: (FORM Event.code=On Clicked)
// déterminer le niveau dans la LH
This.itemRef:=Selected list items(LHdesItems; *) // on veut une référence
GET LIST ITEM(LHdesItems; List item position(LHdesItems; This.itemRef); $itemRef; $itemText)
CONFIRM("La suppression est définitive."+Char(13)+"Supprimer?"; "Non"; "Oui")
If (ok=0)
DELETE FROM LIST(LHdesItems; $itemRef; *)
End if
End case
Function _FORM_ListeHdesFichiers()
var $itemRef : Integer
var $itemText : Text
Case of
: (FORM Event.code=On Load)
OBJECT SET VISIBLE(*; "fichier@"; False)
OBJECT SET VISIBLE(*; "groupe@"; False)
OBJECT SET VISIBLE(*; "constante@"; False)
: (FORM Event.code=On Selection Change)
This.itemPos:=Selected list items(LHdesItems)
GET LIST ITEM(LHdesItems; This.itemPos; $itemRef; $itemText)
This.itemRef:=$itemRef
Case of
: (This.itemRef<100)
// on a cliqué sur un fichier
OBJECT SET VISIBLE(*; "fichier@"; True)
OBJECT SET VISIBLE(*; "groupe@"; False)
OBJECT SET VISIBLE(*; "constante@"; False)
: (This.itemRef<10000)
// on a cliqué sur un groupe
OBJECT SET VISIBLE(*; "fichier@"; True)
OBJECT SET VISIBLE(*; "groupe@"; True)
OBJECT SET VISIBLE(*; "constante@"; False)
: (This.itemRef<1000000)
// on a une constante
OBJECT SET VISIBLE(*; "fichier@"; True)
OBJECT SET VISIBLE(*; "groupe@"; True)
OBJECT SET VISIBLE(*; "constante@"; True)
End case
End case
If ((FORM Event.code=On Load) | (FORM Event.code=On Selection Change))
This._AfficherConstante()
End if
Function _FORM_FichierNom()
Case of
: (FORM Event.code=On Data Change)
This._ModifierUnNomCST(This.FichierID)
End case
Function _FORM_GroupeNom()
Case of
: (FORM Event.code=On Data Change)
This._ModifierUnNomCST(This.GroupeID)
End case
Function _FORM_ConstanteNom()
Case of
: (FORM Event.code=On Data Change)
This._ModifierUnNomCST(This.ConstanteID)
End case
Function _FORM_ConstanteValeur()
Case of
: (FORM Event.code=On Data Change)
This.itemRef:=Selected list items(LHdesItems; *)
SET LIST ITEM PARAMETER(LHdesItems; This.itemRef; "d4:value"; This[This.nomOBJ])
End case
Function _FORM_ConstanteType()
var $ConstanteType : Text
Case of
: (FORM Event.code=On Load)
Form[This.nomOBJ]:=New object
Form[This.nomOBJ].values:=New collection("automatique"; "type Entier Long"; "type Réel"; "type Chaine")
Form[This.nomOBJ].constantesType:=New collection("A"; "L"; "R"; "S")
Form[This.nomOBJ].index:=-1
: (FORM Event.code=On Data Change)
This.itemRef:=Selected list items(LHdesItems; *)
$ConstanteType:=Form["ConstanteType"].constantesType[Form["ConstanteType"].index]
SET LIST ITEM PARAMETER(LHdesItems; This.itemRef; "restype"; $ConstanteType)
End case
Function _LireParametreLH_text($attribut : Text)->$result : Text
GET LIST ITEM PARAMETER(LHdesItems; This.itemRef; $attribut; $result)
Function _LireParametreLH_int($attribut : Text)->$result : Integer
GET LIST ITEM PARAMETER(LHdesItems; This.itemRef; $attribut; $result)
Function _ModifierUnNomCST($refItem : Integer)
// modifier le nom de l'élément $refItem de la LH et de son paramètre
// rappel son nom est une chaine localisée
var $itemText : Text
This._getSelectedItem($refItem)
$itemText:=This[This.nomOBJ]
//SET LIST ITEM PARAMETER(LHdesItems; This.itemRef; "d4:groupName"; This[This.nomOBJ])
//$itemText:="STR '"+This[This.nomOBJ]+"' non definie"
//If (OB Is defined(This.NomsGroupeXLF; This[This.nomOBJ]))
//$itemText:=This.NomsGroupeXLF[This[This.nomOBJ]]
//End if
SET LIST ITEM(LHdesItems; This.itemRef; $itemText; This.itemRef; This.sousListe; This.deployee)
Function _getSelectedItem($refItem : Integer)
var $itemText : Text
var $sousListe : Integer
var $déployée : Boolean
// sélectionner l'élément $refItem en modification (fichier, groupe ou constante)
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $refItem); $itemRef; $itemText; $sousListe; $déployée)
This.itemRef:=$itemRef
This.itemText:=$itemText
This.sousListe:=$sousListe
This.deployee:=$déployée
//--------------------
//MARK:Modification XLF
//--------------------
Function _LireFichierXLF()
var $fichier : 4D.File
var $c : Collection
var $racineXML; $ElementXML; $itemText; $typeConstante : Text
var $i; $j; $k; $sousListeH; $sousSousListeH; $itemRef; $groupID : Integer
var LHdesItems : Integer
// lire les labels des groupes
This._LireNomsGroupeXLF()
OBJECT SET VISIBLE(LHdesItems; False)
// construire la LH
LHdesItems:=New list
// lister les fichiers .xlf
$c:=Folder(fk resources folder; *).files(fk ignore invisible).query("extension = :1"; ".xlf")
For each ($fichier; $c)
Case of
: (OB Is empty(This.NomsGroupeXLF))
: ($fichier.isFolder)
Else
$i:=$c.indexOf($fichier)+1
// c'est ok, on a un candidat
$RacineXML:=DOM Parse XML source($fichier.platformPath)
// il existe en ressources 2 types de données : "x-STR#" pour les localisations et "x-4DK#" pour les constantes
// chercher le second type
$ElementXML:=DOM Find XML element($racineXML; "file")
DOM GET XML ATTRIBUTE BY NAME($ElementXML; "datatype"; $typeConstante)
If ($typeConstante="x-4DK#")
// c'est ok
// rechercher les groupes
ARRAY TEXT($Groupes; 0)
$ElementXML:=DOM Find XML element($ElementXML; "body/group"; $Groupes)
// on a des groupes, lister le nom de chacun
If (Size of array($Groupes)>0)
$sousListeH:=New list
For ($j; 1; Size of array($Groupes))
ARRAY TEXT($Constantes; 0)
$ElementXML:=DOM Find XML element($Groupes{$j}; "trans-unit"; $Constantes)
DOM GET XML ATTRIBUTE BY NAME($Groupes{$j}; "d4:groupID"; $groupID)
// on a des constantes, les souslister
If (Size of array($Constantes)>0)
$sousSousListeH:=New list
For ($k; 1; Size of array($Constantes))
$ElementXML:=DOM Get XML element($Constantes{$k}; "source"; 1; $itemText)
// 99 id de constantes possibles pour le groupe courant
$itemRef:=((($i*100)+$j)*100)+$k
APPEND TO LIST($sousSousListeH; $itemText; $itemRef)
SET LIST ITEM PARAMETER($sousSousListeH; $itemRef; "id"; $itemRef)
SET LIST ITEM PARAMETER($sousSousListeH; $itemRef; "nom"; $itemText)
// lire les données de la constante
// et mémoriser les données de la constante, nécessaires aux modifications et à la création du fichier
DOM GET XML ATTRIBUTE BY NAME($Constantes{$k}; "d4:value"; $itemText)
SET LIST ITEM PARAMETER($sousSousListeH; $itemRef; "d4:value"; $itemText)
SET LIST ITEM PARAMETER($sousSousListeH; $itemRef; "constanteID"; ($groupID*100)+$k)
End for
// créer la sous listeH
DOM GET XML ATTRIBUTE BY NAME($Groupes{$j}; "d4:groupName"; $itemText)
// 99 id de groupe possibles pour le fichier courant
$itemRef:=($i*100)+$j
APPEND TO LIST($sousListeH; This.NomsGroupeXLF[$itemText]; $itemRef; $sousSousListeH; False)
SET LIST ITEM PARAMETER($sousListeH; $itemRef; "id"; $itemRef)
SET LIST ITEM PARAMETER($sousListeH; $itemRef; "nom"; $itemText)
// mémoriser les données nécessaires à la création du fichier
SET LIST ITEM PARAMETER($sousListeH; $itemRef; "d4:groupName"; $itemText)
SET LIST ITEM PARAMETER($sousListeH; $itemRef; "d4:groupID"; $groupID)
DOM GET XML ATTRIBUTE BY NAME($Groupes{$j}; "restype"; $itemText) // en principe on a "x-4DK#"
SET LIST ITEM PARAMETER($sousListeH; $itemRef; "restype"; $itemText)
End if
End for
// ajouter à la liste (99 fichiers possibles)
APPEND TO LIST(LHdesItems; $fichier.name; $i; $sousListeH; True)
// mémoriser les données nécessaires à la création du fichier
SET LIST ITEM PARAMETER(LHdesItems; $i; "id"; $i)
SET LIST ITEM PARAMETER(LHdesItems; $i; "datatype"; $typeConstante)
SET LIST ITEM PARAMETER(LHdesItems; $i; "nom"; $fichier.name)
End if
End if
DOM CLOSE XML($racineXML)
End case
End for each
If (Count list items(LHdesItems; *)=0)
// créer un fichier vide
APPEND TO LIST(LHdesItems; "Constantes"; 1)
SET LIST ITEM PARAMETER(LHdesItems; 1; "id"; 1)
SET LIST ITEM PARAMETER(LHdesItems; 1; "nom"; "Constantes")
End if
SORT LIST(LHdesItems; >)
OBJECT SET VISIBLE(LHdesItems; Count list items(LHdesItems)>0)
// sélectionner l'élément mémorisé
$itemRef:=This._LireUserPrefs("IDconstante"; Is longint)
SELECT LIST ITEMS BY REFERENCE(LHdesItems; $itemRef)
OBJECT SET SCROLL POSITION(LHdesItems; List item position(LHdesItems; Selected list items(LHdesItems; *)))
Function _AjouterXLF()
var btnModifierXLF : Integer
var $itemRef; $sousListe; $i; $listeH : Integer
var $itemText; $nomObjet : Text
var $déployée : Boolean
// déterminer le niveau dans la LH
$itemRef:=Selected list items(LHdesItems; *) // on veut une référence
// information du niveau
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $itemRef); $itemRef; $itemText; $sousListe; $déployée)
// le fichier ou le groupe est peut être vide : il faut initialiser une sous liste
If (($itemRef#0) & ($sousListe=0))
$sousListe:=New list
// l'accrocher
SET LIST ITEM(LHdesItems; $itemRef; $itemText; $itemRef; $sousListe; True)
End if
// chercher un ID libre
// les sous listes ne sont pas forcément déployées : rechercher dans une copie
$listeH:=Copy list(LHdesItems)
// début de la recherche
$i:=($itemRef*100)+1 // c'est le premier potentiellement existant
While (List item position($listeH; $i)>0)
$i:=$i+1
End while
CLEAR LIST($listeH)
Case of
: ($itemRef=0)
// on ajoute un fichier
$nomObjet:="Fichier "+String($i)
APPEND TO LIST(LHdesItems; $nomObjet; $i)
: ($itemRef<100)
// on ajoute un groupe à un fichier
// on ajoute un fichier
$nomObjet:="Groupe "+String($i)
APPEND TO LIST($sousListe; $nomObjet; $i)
SET LIST ITEM PARAMETER(LHdesItems; $i; "d4:groupName"; $nomObjet)
SET LIST ITEM PARAMETER(LHdesItems; $i; "d4:groupID"; $i)
SET LIST ITEM PARAMETER(LHdesItems; $i; "restype"; "x-4DK#")
: ($itemRef<10000)
// on ajoute une constante à un groupe
$nomObjet:="Constante "+String($i)
APPEND TO LIST($sousListe; $nomObjet; $i)
SET LIST ITEM PARAMETER(LHdesItems; $i; "nom"; $nomObjet)
SET LIST ITEM PARAMETER(LHdesItems; $i; "constanteID"; $i)
SET LIST ITEM PARAMETER(LHdesItems; $i; "d4:value"; "")
End case
// trier
SORT LIST(LHdesItems; >)
// afficher
SELECT LIST ITEMS BY REFERENCE(LHdesItems; $i)
//--------------------
//MARK:User prefs
//--------------------
Function _LireUserPrefs($cheminXML : Text; $typeValeur : Integer)->$result : Variant
// lire la donnée au chemin $cheminXML du fichier user prefs
// et fixer la valeur de $ptrData
var $data : Object
// valeur d'erreur
Case of
: ($typeValeur=Is longint)
$result:=1
: ($typeValeur=Is text)
$result:=""
Else
$result:=Null
End case
$data:=New object
Case of
: (Not(This._OuvrirFichierPréférences(->$data)))
// pas de données
: (Not(OB Is defined($data; $cheminXML)))
// pas de valeur
Else
// renvoyer la valeur lue
$result:=OB Get($data; $cheminXML; $typeValeur)
End case
Function _EcrireUserPrefs($cheminXML : Text; $valeur : Variant)
var $data : Object
$data:=New object
If (This._OuvrirFichierPréférences(->$data))
// écrire la valeur
OB SET($data; $cheminXML; $valeur)
// enregistrer le fichier
This._FermerFichierPréférences($data)
End if
Function _OuvrirFichierPréférences($ptrData : Pointer)->$result : Boolean
// renvoyer dans $data les préférences
var $fichier : 4D.File
var $datatexte : Text
$result:=False
$fichier:=Folder(fk resources folder).file("Preferences.json")
//$fichier:=Documents systeme("BuildFilePath"; Get 4D folder(Current resources folder); "Preferences.json")
Case of
: (Not($fichier.exists))
: (Not($fichier.isFile))
Else
// lire les données
$datatexte:=Document to text($fichier.platformPath; "UTF-8")
$ptrData->:=OB Copy(JSON Parse($datatexte; Is object))
$result:=True
End case
Function _FermerFichierPréférences($data : Object)
var $fichier : 4D.File
var $datatexte : Text
$fichier:=Folder(fk resources folder).file("Preferences.json")
// écrire les préférences
$datatexte:=JSON Stringify($data)
TEXT TO DOCUMENT($fichier.platformPath; $datatexte)
//--------------------
//MARK:Fichiers .XLIFF
//--------------------
Function _EnregistrerXLIFF()
// créer les fichiers .lproj de toutes les langues
// commencer par le fichier "structure"
This.fichier:="Structure.xlf"
// STRID de 1 à 499 : texte de formulaire
// STRID de 500 à 999 : texte de bulles et libellés d'aide
// STRID de 1000 à 1999 : autre texte de formulaire
This.STRidMin:=0
This.STRidMax:=1999
This._CreerFichierRessourceXLIFF()
// le fichier "Menus"
This.fichier:="Menus.xlf"
// STRID de 3000 à 3999 : texte de menus
This.STRidMin:=3000
This.STRidMax:=3999
This._CreerFichierRessourceXLIFF()
// le fichier "informations"
This.fichier:="Informations.xlf"
// STRID de 5000 à 5999 : texte de messages, informations...
This.STRidMin:=5000
This.STRidMax:=5999
This._CreerFichierRessourceXLIFF()
// le fichier "aides"
This.fichier:="Aide.xlf"
// STRID de 6000 à 6999 : pages d'aide
// STRID de 7000 à 7999 : textes d'aide
This.STRidMin:=6000
This.STRidMax:=7999
This._CreerFichierRessourceXLIFF()
// les traductions "Listes"
This.fichier:="Listes.xlf"
// STRID de 10000 à 99999
This.STRidMin:=10000
This.STRidMax:=99999
This._CreerFichierRessourceXLIFF()
// les traductions "popUpmenus"
This.fichier:="PopUpMenus.xlf"
// STRID de 100000 à 999999 : libellé des menus popUp
This.STRidMin:=100000
This.STRidMax:=999999
This._CreerFichierRessourceXLIFF()
// le fichier "composant_xxx" (seul le fichier du composant courant est généré)
// récupérer le IDcomposant
// trouver STRID = 16x00000
ARRAY LONGINT($tabSTRid; 0)
ARRAY TEXT($tabTraductionslangueCible; 0)
Begin SQL
SELECT localizedSTR.libelle, translations.STRid
FROM localizedSTR
INNER JOIN translations ON localizedSTR.STRid = translations.id
WHERE localizedSTR.langue = 'fr' AND translations.STRid >= 16000000 AND translations.STRid <= 16999999
INTO :$tabTraductionslangueCible, :$tabSTRid;
End SQL
SORT ARRAY($tabSTRid; $tabTraductionslangueCible; >)
If (Size of array($tabSTRid)>0)
// utiliser le premier élément
This.fichier:="Composant_"+String($tabTraductionslangueCible{1})+".xlf"
// STRID de $tabSTRid{1}+1 à $tabSTRid{1}+1+99999 : libellé des chaines partagées
This.STRidMin:=$tabSTRid{1}+1
This.STRidMax:=$tabSTRid{1}+1+99999
This._CreerFichierRessourceXLIFF()
End if
// les traductions "LabelsErreur"
This.fichier:="LabelsErreur.xlf"
// STRID de -15999 à -15000 : libellé des erreurs de l'application ALVs
This.STRidMin:=-15999
This.STRidMax:=-15000
This._CreerFichierRessourceXLIFF()
// les traductions erreurs des composants
This.fichier:="LabelsErreurComposant.xlf"
// STRID de -16999 à -16000 : libellé des erreurs des composants (seul le fichier du composant courant est généré)
This.STRidMin:=-16999
This.STRidMax:=-16000
This._CreerFichierRessourceXLIFF()
Function _CreerFichierRessourceXLIFF()
// créer le fichier this.fichier dans toutes les langues gérées
var $dossier : 4D.Folder
var $langue; $Xpath; $fichier : Text
var $ElementXML; $EnfantXML : Text
var $success : Boolean
// lister toutes les langues gérées (code langue au format RFC)
This.liste:=cs.Outils.me.ListerLanguesApplication().codes
// pour toutes les langues
For each ($langue; This.liste)
// chemin du fichier .lproj en ressource (BDD mère)
$dossier:=Folder(fk resources folder; *)
// Conformément à la RFC, le fichier utilise _ comme séparateur langue/région
$dossier:=$dossier.folder(Replace string($langue; "-"; "_"; *)+".lproj")
$dossier.create()
// créer la structure XML
This.racineXML:=DOM Create XML Ref("xliff")
DOM SET XML ATTRIBUTE(This.racineXML; "version"; "1.1")
//écrire l'entête
$Xpath:="file"
$ElementXML:=DOM Create XML element(This.racineXML; $Xpath; "datatype"; "xml"; "original"; "undefined"; "source-language"; "fr"; "target-language"; $langue)
$EnfantXML:=DOM Create XML element($ElementXML; $Xpath+"/header/note"; "comment"; "Lecture d'un élément : soit par :xliff:resname, soit par IDgroup:id")
$EnfantXML:=DOM Create XML element($ElementXML; $Xpath+"/header/prop-group"; "name"; "AinsiLaVie_"+Current method name)
// écrire les traductions dans la langue '$itemText'
This.Langue:=$langue
$success:=This._AjouterElements($ElementXML)
// écrire la structure XML dans le fichier
If ($success)
// il y a eu des libellés
$fichier:=$dossier.platformPath+This.fichier
DOM EXPORT TO FILE(This.racineXML; $fichier) // génère une erreur
End if
DOM CLOSE XML(This.racineXML)
End for each
Function _AjouterElements($aXML : Text)->$result : Boolean
// créer dans $aXML N groupes de paires resname / traduction
var $langue : Text
var $STRidMin; $STRidMax : Integer
var $i; $j; $numGroup : Integer
var $groupID; $RacineXML; $ElementXML; $Xpath : Text
// au cas où..
This._OuvrirBDD()
// retypage pour SQL
$langue:=This.Langue
$STRidMin:=This.STRidMin
$STRidMax:=This.STRidMax
$result:=False // rien de créer
$numGroup:=0 // nombre de groupes effectivement créés
// lire tous les groupes de traductions
ARRAY TEXT($tabGroupID; 0)
Begin SQL
SELECT DISTINCT nom_group FROM translations INTO :$tabGroupID;
End SQL
// pour tous les groupes
For ($j; 1; Size of array($tabGroupID))
$groupID:=$tabGroupID{$j}
// lire toutes les traductions entre $STRidMin et $STRidMax, en langue $langue du groupe courant
ARRAY LONGINT($tabSTRid; 0)
ARRAY TEXT($tabTraductionslangueCible; 0)
Begin SQL
SELECT localizedSTR.libelle, translations.STRid
FROM localizedSTR
INNER JOIN translations ON localizedSTR.STRid = translations.id
WHERE localizedSTR.langue = :$langue AND translations.STRid >= :$STRidMin AND translations.STRid <= :$STRidMax AND translations.nom_group = :$groupID
INTO :$tabTraductionslangueCible, :$tabSTRid;
End SQL
// ce groupe n'a pas forcément des ressources entre $STRidMin et $STRidMax
If (Size of array($tabSTRid)>0)
// il y a des chaines
$numGroup:=$numGroup+1
// trier les patates
SORT ARRAY($tabSTRid; $tabTraductionslangueCible; >)
// récupérer la racine
DOM GET XML ELEMENT NAME($aXML; $Xpath)
$RacineXML:=DOM Find XML element($aXML; $Xpath)
$Xpath:=$Xpath+"/body/group"+"["+String($numGroup)+"]"
// créer un nouveau group
$ElementXML:=DOM Create XML element($RacineXML; $Xpath; "id"; $groupID)
$Xpath:=$Xpath+"/trans-unit"
// pour toutes les chaines
For ($i; 1; Size of array($tabSTRid))
// ajouter un nouveau trans-unit avec STRid
$ElementXML:=DOM Create XML element($RacineXML; $Xpath+"["+String($i)+"]"; "id"; String($tabSTRid{$i}); "resname"; String($tabSTRid{$i}))
// pour accéder à cette ressource dans 4D, il faut utiliser la synthaxe type v2004 "IDgroup:IDtrans-unit" ou le resname ":xliff:resname"
$ElementXML:=DOM Create XML element($RacineXML; $Xpath+"["+String($i)+"]/source")
DOM SET XML ELEMENT VALUE($ElementXML; "Ressource_"+String($tabSTRid{$i}))
$ElementXML:=DOM Create XML element($RacineXML; $Xpath+"["+String($i)+"]/target")
DOM SET XML ELEMENT VALUE($ElementXML; $tabTraductionslangueCible{$i})
End for
End if
$result:=$result | (Size of array($tabSTRid)>0)
End for
Function _LireNomsGroupeXLF()
// renvoie le nom des groupes XLF
var $i : Integer
ARRAY LONGINT($tabSTRid; 0)
ARRAY TEXT($tabTraductionslangueCible; 0)
This._OuvrirBDD()
// 15000 à 15999 pour la BDDmère, 16000 à 16999 pour les composants
Begin SQL
SELECT localizedSTR.libelle, translations.STRid
FROM localizedSTR
INNER JOIN translations ON localizedSTR.STRid = translations.id
WHERE localizedSTR.langue = 'fr' AND translations.STRid >= 15000 AND translations.STRid <= 16999
INTO :$tabTraductionslangueCible, :$tabSTRid;
End SQL
This._FermerBDD()
This.NomsGroupeXLF:=New object
For ($i; 1; Size of array($tabSTRid))
This.NomsGroupeXLF[String($tabSTRid{$i})]:=$tabTraductionslangueCible{$i}
End for
//--------------------
//MARK:Fichiers .XLF
//--------------------
Function _FORM_EnregistrerXLF()
var $success; $déployée : Boolean
var $dossier; $fichier; $RacineXML; $ElementXML; $EnfantXML : Text
var $i; $sousListe : Integer
// créer les fichiers
// fixer le chemin des fichiers XLF à enregistrer
// on est installé en ressource
$dossier:=Folder(fk resources folder; *).platformPath
// boucle sur les éléments déployés
For ($i; 1; Count list items(LHdesItems))
GET LIST ITEM(LHdesItems; $i; $itemRef; $itemText; $sousListe; $déployée)
Case of
: ($sousListe=0)
: ($itemRef>=100)
Else
// on a un fichier
$RacineXML:=DOM Create XML Ref("xliff")
DOM SET XML DECLARATION($RacineXML; "utf-8"; False)
DOM SET XML ATTRIBUTE($RacineXML; "version"; "1.0"; "xmlns:d4"; "http://www.4d.com/d4-ns")
//écrire l'entête
$ElementXML:=DOM Create XML element($RacineXML; "file"; "datatype"; "x-4DK#"; "original"; "undefined"; "source-language"; "x-none"; "target-language"; "x-none")
$EnfantXML:=DOM Create XML element($ElementXML; "header/prop-group"; "name"; "AinsiLaVie_"+Current method name)
$ElementXML:=DOM Create XML element($ElementXML; "body")
// créer le contenu du fichier de constantes
$success:=This._CreerFichierXLF($itemRef; $ElementXML)
// écrire la structure XML dans le fichier
If ($success)
// il y a eu des libellés
GET LIST ITEM PARAMETER(LHdesItems; $itemRef; "nom"; $fichier)
DOM EXPORT TO FILE($RacineXML; $dossier+$fichier+".xlf") // génère une erreur
End if
DOM CLOSE XML($RacineXML)
End case
End for
If ($success)
CONFIRM("La prise en compte des modifications nécessite de re-démarrer l'application."+Char(13)+"Re-démarrer?"; "Oui"; "Non")
If (ok=1)
OPEN DATABASE(Structure file(*))
End if
End if
Function _CreerFichierXLF($deItemRef : Integer; $aXML : Text)->$success : Boolean
var $itemText; $texte : Text
var $ElementXML; $EnfantXML : Text
var $itemRef; $sousListe; $i; $groupID : Integer
var $déployée : Boolean
$success:=False
Case of
: ($deItemRef<100)
// écrire les groupes du fichier $deItemRef
// * liste des groupes du fichier
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $deItemRef); $itemRef; $itemText; $sousListe; $déployée)
// * boucle sur les groupes de $itemRef
// rappel : il faut que la sous liste soit déployée, sinon le nombre d'éléments de $sousListe est nul
SET LIST ITEM(LHdesItems; $itemRef; $itemText; $itemRef; $sousListe; True)
For ($i; 1; Count list items($sousListe))
// récupérer le itemRef et le nom du groupe
GET LIST ITEM($sousListe; $i; $itemRef; $itemText)
// remarque : des éléments de la sous liste sont peut-être déployés; les filtrer
If (($itemText#"") & ($itemRef#0))
// créer le groupe
$ElementXML:=DOM Create XML element($aXML; "group["+String($i)+"]")
// attributs du groupe
GET LIST ITEM PARAMETER($sousListe; $itemRef; "d4:groupID"; $texte)
DOM SET XML ATTRIBUTE($ElementXML; "d4:groupID"; $texte)
GET LIST ITEM PARAMETER($sousListe; $itemRef; "d4:groupName"; $texte)
DOM SET XML ATTRIBUTE($ElementXML; "d4:groupName"; $texte)
GET LIST ITEM PARAMETER($sousListe; $itemRef; "restype"; $texte)
DOM SET XML ATTRIBUTE($ElementXML; "restype"; $texte)
// écrire les constantes du groupe
$success:=This._CreerFichierXLF($itemRef; $ElementXML)
End if
End for
// restaurer l'état
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $deItemRef); $itemRef; $itemText)
SET LIST ITEM(LHdesItems; $itemRef; $itemText; $itemRef; $sousListe; $déployée)
: ($deItemRef<10000)
// écrire les constantes du groupe $1, dans $aXML
// ID du groupe
GET LIST ITEM PARAMETER(LHdesItems; $deItemRef; "d4:groupID"; $groupID)
// * liste des constantes du groupe
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $deItemRef); $itemRef; $itemText; $sousListe; $déployée)
// rappel : il faut que la sous liste soit déployée, sinon le nombre d'éléments de $sousListe est nul
SET LIST ITEM(LHdesItems; $itemRef; $itemText; $itemRef; $sousListe; True)
//* boucle sur les constantes de $1
For ($i; 1; Count list items($sousListe))
// récupérer le id et le nom de la constante
GET LIST ITEM($sousListe; $i; $itemRef; $itemText)
// créer la constante
// attention : il existe déjà un élément "trans-unit" (nom du groupe), faire +1
$ElementXML:=DOM Create XML element($aXML; "trans-unit["+String($i)+"]")
DOM SET XML ATTRIBUTE($ElementXML; "id"; ($groupID*100)+$i)
// valeur de la contante
GET LIST ITEM PARAMETER($sousListe; $itemRef; "d4:value"; $texte)
DOM SET XML ATTRIBUTE($ElementXML; "d4:value"; $texte)
// nom de la constante
$EnfantXML:=DOM Create XML element($ElementXML; "source")
DOM SET XML ELEMENT VALUE($EnfantXML; $itemText)
$EnfantXML:=DOM Create XML element($ElementXML; "target")
DOM SET XML ELEMENT VALUE($EnfantXML; $itemText)
End for
// restaurer l'état
GET LIST ITEM(LHdesItems; List item position(LHdesItems; $deItemRef); $itemRef; $itemText)
SET LIST ITEM(LHdesItems; $itemRef; $itemText; $itemRef; $sousListe; $déployée)
$success:=True
Else
// erreur
End case
//--------------------
//MARK:BDD
//--------------------
Function _OuvrirBDD()->$result : Text
// ouvrir la BDD si existe, sinon la créer
var $sql_BDDpath : Text
$sql_BDDpath:=This.sql_BDDpath
If (Test path name($sql_BDDpath+".4DB")=Is a document)
Begin SQL
USE DATABASE DATAFILE :$sql_BDDpath AUTO_CLOSE;
End SQL
Else
// créer le fichier
CREATE FOLDER($sql_BDDpath; *)
// on crée une BDD neuve
Begin SQL
CREATE DATABASE IF NOT EXISTS DATAFILE :$sql_BDDpath;
USE DATABASE DATAFILE :$sql_BDDpath;
CREATE TABLE IF NOT EXISTS translations (id INT PRIMARY KEY, STRid INT, nom_group VARCHAR);
ALTER TABLE translations MODIFY id ENABLE AUTO_INCREMENT;
CREATE TABLE IF NOT EXISTS localizedSTR (id INT PRIMARY KEY, STRid INT, langue VARCHAR, libelle VARCHAR);
ALTER TABLE localizedSTR MODIFY id ENABLE AUTO_INCREMENT;
End SQL
End if
$result:=$sql_BDDpath
Function _FermerBDD()
Begin SQL
USE DATABASE SQL_INTERNAL;
End SQL
⇧
[class]Outils - 20/02/2026 11:26:58
property nomAttribut : Text
singleton Class constructor()
This.nomAttribut:=""
//--------------------
//MARK:Divers
//--------------------
Function CopierAttributs($Obj_src : Object; $Obj_attributs : Object; $créer : Boolean)
var $Txt_property : Text
If (Count parameters=2)
$créer:=True
End if
For each ($Txt_property; $Obj_src)
If (OB Is defined($Obj_attributs; $Txt_property) | $créer)
Case of
: (Value type($Obj_src[$Txt_property])=Is object)
$Obj_attributs[$Txt_property]:=New object
This.CopierAttributs($Obj_src[$Txt_property]; $Obj_attributs[$Txt_property])
: (Value type($Obj_src[$Txt_property])=Is collection)
$Obj_attributs[$Txt_property]:=New collection
$Obj_attributs[$Txt_property]:=$Obj_src[$Txt_property].copy()
Else
$Obj_attributs[$Txt_property]:=$Obj_src[$Txt_property]
End case
End if
End for each
Function getTextDeTypeProcess($numProc : Integer)->$result : Text
var $data : Object
$data:=Process activity(Processes only)["processes"].query("number = :1"; $numProc)[0]
Case of
: ($data.type=Execute on client process)
$result:="Process Client"
: ($data.type=Execute on server process)
$result:="Process Serveur"
: ($data.type=Other user process)
$result:="Process Utilisateur"
: ($data.type=Worker process)
$result:="Process Worker"
Else
$result:="Process type "+String($data.type)
End case
$result:=$result+" "+Choose($data.preemptive; "pré-emptif"; "coopératif")
Function ListerLanguesApplication()->$result : Object
// valeurs par défaut (utilisent pour un composant hors hôte)
$result:=New object("values"; ["Allemand"; "Anglais"; "Espagnol"; "Français"]; "codes"; ["de"; "en"; "es"; "fr"])
Function CalculerRectangleMedia($ptrGauche : Pointer; $ptrHaut : Pointer; $ptrDroite : Pointer; $ptrBas : Pointer; $largeur : Integer; $hauteur : Integer; $ptrZoom : Pointer; $ptrScrollX : Pointer; $ptrScrollY : Pointer)->$result : Integer
var $gauche; $haut; $droite; $bas : Integer
var $Zoom; $ScrollX; $ScrollY; $Cxy; $Cx; $Cy : Real
$result:=0 //par d'erreur
Case of
: (Count parameters<5)
$result:=-2
Else
$gauche:=$ptrGauche->
$haut:=$ptrHaut->
$droite:=$ptrDroite->
$bas:=$ptrBas->
$Zoom:=$ptrZoom->
If ($Zoom<0) //calculer le zoom de l'image en fonction du format demandé
$Cx:=($droite-$gauche)/$largeur // échelle en largeur
$Cy:=($bas-$haut)/$hauteur // échelle en hauteur
$Cxy:=($droite-$gauche)/$largeur*$hauteur/($bas-$haut) //rapport des 2 échelles
Case of
: ($Zoom=-Truncated centered) // image proportionnelle tronquée
$Zoom:=($Cx*Num($Cxy>1))+($Cy*Num($Cxy<=1))
: (($Zoom=-Scaled to fit prop centered) | ($Zoom=(-10-Scaled to fit prop centered))) // image proportionnelle non tronquée
$Zoom:=($Cx*Num($Cxy<1))+($Cy*Num($Cxy>=1))
If (($ptrZoom->=(-Scaled to fit prop centered)) & ($zoom>1))
$zoom:=1 //on ne veut pas augmenter la taille d'une petite image
End if
Else
$result:=-1
End case
$ptrZoom->:=$Zoom
End if
If (($result=0) & (Count parameters=9))
$ScrollX:=$ptrScrollX->
$ScrollY:=$ptrScrollY->
$ptrGauche->:=($gauche+$droite)/2+$ScrollX-($largeur*$Zoom/2)
$ptrHaut->:=($haut+$bas)/2+$ScrollY-($hauteur*$Zoom/2)
$ptrDroite->:=$ptrGauche->+($largeur*$Zoom)
$ptrBas->:=$ptrHaut->+($hauteur*$Zoom)
$ptrScrollX->:=$ptrGauche->-$gauche
$ptrScrollY->:=$ptrHaut->-$haut
End if
End case
//--------------------
//MARK:Traitement de chaine
//--------------------
Function EffacerLesRC($texte : Text)->$result : Text
$result:=Replace string($texte; Char(Carriage return); " ")
Function FormaterNomXML($texte : Text)->$result : Text
$result:=Replace string($texte; " "; "_"; *)
$result:=Replace string($result; "/"; "-"; *)
Function FormaterHTML($texte : Text)->$result : Text
$result:=Replace string($texte; " "; "_"; *)
$result:=Replace string($result; "."; "_"; *)
$result:=Replace string($result; Char(NBSP ASCII CODE); "_"; *)
Function PropriétariserNomProcess($texte : Text)->$result : Text
var $i : Integer
// récupérer les 2 premiers éléments du nom du process
$i:=Position("+?"; $texte)
$result:=Substring($texte; 1; Choose($i=0; Length($texte); $i-1))
// supprimer les ? (sinon, ne peut être utilisé comme nom de propriété)
$result:=Replace string($result; "?"; "-")
Function ContientJoker($texte : Text)->$result : Boolean
// renvoie une chaine vide si $2 comtient '@'
var $i : Integer
$result:=False
If (Length($texte)>0)
For ($i; 1; Length($texte))
If (Character code(Substring($texte; $i; 1))=Character code("@"))
$result:=True
End if
End for
End if
Function ConvertirPathVersURL($path : Text; $Without_First : Boolean; $From_User : Boolean; $Without_Root : Boolean)->$result : Text
var $i; $length : Integer
var $volume : Text
If (Count parameters<4)
$Without_Root:=False
If (Count parameters<3)
$From_User:=False
If (Count parameters<2)
$Without_First:=False
End if
End if
End if
Case of
: (Length($path)=0)
$result:=""
: (Is Windows)
$result:=Replace string($path; "\\"; "/"; *)
Else
//Space character must be escaped
//$path:=Remplacer chaine($path;" ";"\\ ";*)
// Get the boot volume
$volume:=System folder //"Macintosh_HD:System:"
$length:=Length($volume)
For ($i; 1; $length; 1)
If ($volume[[$i]]=":")
$volume:=Substring($volume; 1; $i-1)
$i:=$length+1
End if
End for
Case of
: $Without_Root
$result:=Replace string($path; " "; "%20"; *)
: ($From_User) & ($path=($volume+":@"))
$result:=Replace string($path; $volume; ""; 1; *)
$result:=Replace string($result; " "; "%20"; *)
Else
If ($path=($volume+":@"))
// The path is on the boot disk
// Macintosh_HD/Library/..." will be converted to "/Library/..."
$result:=Delete string($path; 1; Position(":"; $path; *)-1)
Else
// The path is not on the boot disk
// Disk/work folder/..." will be converted to "/Volumes/Disk/work%20folder/..."
$result:=":Volumes:"+$path
$result:=Replace string($result; " "; "%20"; *)
End if
End case
// ":" is remplaced by "/"
$result:=Replace string($result; ":"; "/"; *)
End case
Case of
: (Not($Without_First))
: (Length($result)=0)
: (Character code($result[[1]])=47) // /
While (Character code($result[[1]])=47)
$result:=Substring($result; 2)
End while
End case
Function getDateNum($data : Object)->$result : Boolean
var $date; $jour; $mois; $année; $nomDuMois; $nomMois : Text
var $i : Integer
$result:=False
If (OB Is defined($data; "dateChaine"))
$date:=$data.dateChaine
$jour:=Substring($date; 1; Position(" "; $date; *)-1)
$date:=Delete string($date; 1; Position(" "; $date; *))
$nomDuMois:=Substring($date; 1; Position(" "; $date; *)-1)
$date:=Delete string($date; 1; Position(" "; $date; *))
$année:=Substring($date; 1; 4)
$data.dateNumValid:=False
$mois:="01"
For ($i; 12; 1; -1)
$nomMois:=String(Add to date(!1999-12-01!; 0; $i; 0); Internal date long)
$nomMois:=Substring($nomMois; Position(" "; $nomMois; *)+1)
$nomMois:=Substring($nomMois; 1; Position(" "; $nomMois; *)-1) // nom du mois $1 dans la langue courante
If ($nomDuMois=$nomMois)
$mois:=String($i)
$data.dateNumValid:=True
$i:=0
End if
End for
If (Num($année)=0)
$année:="100"
$data.dateNumValid:=False
End if
If (Num($jour)=0) //dernier jour du mois $mois
$jour:=String(Day of(Add to date(Add to date(!00-00-00!; Num($année); Num($mois)+1; 1); 0; 0; -1)))
$data.dateNumValid:=False
End if
$data.dateNum:=Add to date(!00-00-00!; Num($année); Num($mois); Num($jour))
$result:=$data.dateNumValid
End if
⇧
[class]SystemTools - 16/12/2024 13:52:00
property _commande : Text
// ----------------------
// MARK:Réseau
// ----------------------
Function NET_Resolve($domaine : Text)->$adresseIP : Text
var $sw : Object
var $c : Collection
This._commande:="host "+$domaine
$sw:=4D.SystemWorker.new(This._commande)
$sw.wait()
If ($sw.terminated && ($sw.exitCode=0))
$c:=Split string($sw.response; "\n"; sk ignore empty strings)
If ($c.length=1)
$c:=Split string($c[0]; " ")
$adresseIP:=$c.last()
End if
End if
⇧
[class]ExportCode4D - 30/05/2025 17:52:33
property document : cs.$document
property fct : cs.Outils
property racineXML : Text
Class constructor()
This.document:=cs.$document.new()
This.fct:=cs.Outils.me
// ----------------------
// MARK:Formulaire
// ----------------------
Function Démarrer()
var $data : Object
var $numProc; $numProgress : Integer
var $fichier : 4D.File
var $pict : Picture
Case of
// rappel : l'export est utile avec l'APP ou un composant non compilée (sinon le texte du code est vide)
: (Is compiled mode(*))
// application autonome ou en mode développement
: (Storage.System.estServeurWeb)
// serveur Web (pas d'export du code)
Else
// BDD mère toujours, ou composant : appel en fin de session, lancer l'export
If (User in group(Current user; "Développement"))
// c'est ok
// on lance dans un process à part de façon à pouvoir surveiller la progression
// remarque : la méthode hôte "Progression Process" espionne des variables process, ce qui n'est pas possible entre hôte et composant
// => la progression se fait dans le composant par une méthode "Progression Process" locale
InitProcess
$data:=New object
$data.functionID:="_Démarrer_Process"
$data.nomProcess:="SDK_Exporter_Code4D"
$data.nomTache:="$ProcessExporterCode4D"
$data.numProcessAppelant:=-1
$numProc:=Exécuter Function Coopérative(cs.ExportCode4D; $data)
$numProgress:=Progress New
Progress SET WINDOW VISIBLE(False; 40; Screen height-100)
$fichier:=Folder(fk resources folder; *).folder("images").file("16208.png")
READ PICTURE FILE($fichier.platformPath; $pict)
Progress SET ICON($numProgress; $pict)
Progress SET TITLE($numProgress; "Export du code 4D de l'application"; 0; ""; False)
Progress SET WINDOW VISIBLE(True; -1; -1; True)
Progression Process Composant($numProc; 0; 10000; $numProgress)
Progress SET PROGRESS($numProgress; 1)
Progress SET TITLE($numProgress; "Dépôt des fichiers du projet dans le repository Git"; 0; ""; False)
This._DéposerDansDossierGit()
Waiting(30)
Progress QUIT($numProgress)
End if
End case
Function _Démarrer_Process()
var $dossier : 4D.Folder
var $fichier : 4D.File
var $c : Collection
var $path : Text
var vs4D : Text
// init du process
ON ERR CALL(Formula(traceHandler).source; ek local)
ProcInProgressTime:=0
ProcInProgressState:=0
ProcInProgressEtat:=""
ProcInProgressCmd:=""
// dossier du code4D
$dossier:=This._FixerDossierExport()
// copier ici les pages fournies par les composants
$c:=This.document.getStructureFolder().parent.folder("Composants").folder(This._NomDossierExportComposant).files(fk ignore invisible)
For each ($fichier; $c)
$fichier.copyTo($dossier; fk overwrite)
End for each
// exporter le code de la BDD mère dans le dossier :
// ajouter la page de la BDD
vs4D:="pages"
$path:=This._NomFichierExport+".html"
This._CreerPageHTML($path; $dossier; "ALVcode4D.shtml")
// créer l'index
vs4D:="index"
This._CreerPageHTML("Accueil.html"; $dossier; "ALVcode4D.shtml")
// créer le menu de la base hôte
$fichier:=This._FixerDossierExport().file(This._NomFichierMenu)
This._CréerBarreMenus($fichier; "ALVbarreMenusComposant.html")
// créer le menu de l'APP (hôte + commposants)
$fichier:=This._FixerDossierExport().file("Menus_APP.html")
This._CréerBarreMenus($fichier; "ALVbarreMenusAPP.html")
// traiter toutes les balises
This._TraiterBaliseALV($fichier; $fichier)
// dernière étape : insérer la barre de menus complète dans tous les fichiers code4D (sauf ceux de type Menus_)
$c:=$dossier.files(fk ignore invisible).query("name != :1"; "Menus_@")
For each ($fichier; $c)
This._TraiterBaliseALV($fichier; $fichier)
End for each
// nettoyer le dossier (fichiers de type Menus_)
$c:=$dossier.files(fk ignore invisible).query("name = :1"; "Menus_@")
For each ($fichier; $c)
$fichier.delete()
End for each
Function DémarrerComposant()
var $dossier : 4D.Folder
var $fichier : 4D.File
var $url : Text
vs4D:="pages"
// chemin du package du composant COURANT (rappel : l'export est fait par le ALV_sdk installé dans le composant courant)
$dossier:=This.document.getStructureFolder()
// ne s'exécute jamais dans la base hôte => se mettre dans le dossier des matrices composants (remonter l'échelle de 2 niveaux)
$dossier:=$dossier.parent.parent.folder(This._NomDossierExportComposant)
$dossier.create() // au cas où
// ajouter la page du composant
$url:=This._NomFichierExport+".html"
This._CreerPageHTML($url; $dossier; "ALVcode4D.shtml")
// créer le menu hiérarchique du composant
$fichier:=$dossier.file(This._NomFichierMenu)
This._CréerBarreMenus($fichier; "ALVbarreMenusComposant.html")
This._DéposerDansDossierGit()
Function _CreerPageHTML($chemin : Text; $dossier : 4D.Folder; $nomTemplate : Text)
// créer une page statique WEB à partir d'une page dynamique
// Erreur=-16003 si la page n'a pas été créée
var $template; $fichier : 4D.File
var $trace : cs.Traces
var wwwRacineRessources : Text
// fixer la racine de la page
wwwRacineRessources:=This.document.CalculerNiveauRelatifPOSIX($chemin)
// fichier de la page statique
$fichier:=$dossier.file($chemin)
// chemin du template (toujours en ressource de la structure locale (composant ou BDD mère)
$template:=Folder(fk resources folder).folder("TemplatesPagesWeb").file($nomTemplate)
// le fichier template existe
$trace:=This._TraiterBalise4D($template; $fichier)
$trace.FixerSuccess()
$trace.LeverException([msgk_event; msgk_log])
// ----------------------
// MARK:Requetes HTML
// ----------------------
Function _TraiterURL($url : Text)->$result : Object
var $function : Text
$function:=Substring($url; 2)
Case of
: (Not(OB Is defined(This; $function)))
Else
$result:=This[$function]()
End case
Function _EcrireBarreMenusAPP()->$result : Object
// ajouter à $racineXML les balises INCLUDE des composants
var $c : Collection
var $fichier : 4D.File
var $RacineXML; $ElementXML; $ElementXMLenfant; $dataTexte : Text
$RacineXML:=DOM Create XML Ref("nav")
DOM SET XML ATTRIBUTE($RacineXML; "class"; "element-flexible")
$ElementXML:=DOM Create XML element($RacineXML; "ul")
// INCLUDE le menu ALV
$ElementXMLenfant:=DOM Append XML child node($ElementXML; XML comment; "#4DINCLUDE "+This._NomFichierMenu)
// INCLUDE les menus composant
$c:=This.document.getStructureFolder().parent.folder("Composants").folder(This._NomDossierExportComposant).files(fk ignore invisible).query("name = :1"; "Menus_@")
For each ($fichier; $c)
$ElementXMLenfant:=DOM Append XML child node($ElementXML; XML comment; "#4DINCLUDE "+$fichier.fullName)
End for each
DOM EXPORT TO VAR($RacineXML; $dataTexte)
DOM CLOSE XML($RacineXML)
// supprimer la balise <?xml >
$dataTexte:=Substring($dataTexte; Position("<"; $dataTexte; 2; *))
$result:=New object("resultat"; Char(1)+$dataTexte)
Function _EcrireBarreMenusComposants()->$result : Object
// ici on peut être dans la BDD mère ou un composant
// renvoyer sa barre de menus
var $c : Collection
var $url; $chemin; $RacineXML; $RacineXMLlocal; $ElémentXML; $dataTexte : Text
ARRAY TEXT($Elements; 0)
METHOD GET FOLDERS($Elements; *) // liste les dossiers et sous-dossiers
$c:=New collection
ARRAY TO COLLECTION($c; $Elements)
$c.sort()
// ne garder que les dossiers (les sous dossiers sont codés "XX_YY")
// supprimer les sous dossiers (suppose le tableau ordonné)
This._SupprimerSousDossiers("_"; ->$c)
$RacineXML:=DOM Create XML Ref("body")
$RacineXMLlocal:=DOM Create XML element($RacineXML; "li")
$ElémentXML:=DOM Create XML element($RacineXMLlocal; "a"; "href"; "#"; "class"; "sousListeN")
DOM SET XML ELEMENT VALUE($ElémentXML; This._NomComposant)
$RacineXMLlocal:=DOM Create XML element($RacineXMLlocal; "ul")
// Le chemin HTML d'un article est du type ../dossierExport/nom page#idArticle
$url:=This._NomFichierExport+".html"
$url:="../"+This._NomDossierExport+"/"+$url
// Ecrire par dossier la liste des méthodes de la BDD
// hypothèse : pas d'objets à la racine des dossiers
For each ($chemin; $c)
This._EcrireDossiersTdM($url; $RacineXMLlocal; $chemin)
End for each
// ajouter les méthodes base (elles ne peuvent pas être accessibles par les dossiers)
$RacineXMLlocal:=DOM Create XML element($RacineXMLlocal; "li")
$ElémentXML:=DOM Create XML element($RacineXMLlocal; "a")
DOM SET XML ATTRIBUTE($ElémentXML; "href"; "#"; "class"; "sousListeN")
DOM SET XML ELEMENT VALUE($ElémentXML; "Méthodes base")
// la liste
$ElémentXML:=DOM Create XML element($RacineXMLlocal; "ul")
This._EcrireMéthodesBase($url; $ElémentXML)
DOM EXPORT TO VAR($RacineXML; $dataTexte)
DOM CLOSE XML($RacineXML)
// supprimer la balise <?xml >
$dataTexte:=Substring($dataTexte; Position("<"; $dataTexte; 2; *))
$result:=New object("resultat"; Char(1)+$dataTexte)
Function _AjouterTitre()->$result : Object
var $nomAPP; $dataTexte : Text
cs.ResourceALV.me.SetVariable(Est Ressource APP; "Ressources_Communes/Nom_Application"; Is text; ->$nomAPP)
$dataTexte:="Code 4D de "+$nomAPP+" - "+This.document.getStructureFolder().parent.fullName
$dataTexte:=$dataTexte+" du "+String(Current date; System date short)+" "+String(Current time; System time short)
$result:=New object("resultat"; Char(1)+$dataTexte)
Function _AjouterArticles()->$result : Object
var $dataTexte; $nomObjet : Text
var $i : Integer
This.racineXML:=DOM Create XML Ref("section")
DOM SET XML ATTRIBUTE(This.racineXML; "class"; "element-flexible fg1")
If (vs4D="pages")
ARRAY TEXT($Elements; 0)
METHOD GET PATHS(Path all objects; $Elements; *)
For ($i; 1; Size of array($Elements))
$nomObjet:=This._FixerNomObjet($Elements{$i})
This._EcrireArticle($Elements{$i}; $nomObjet)
ProcInProgressTime:=$i/Size of array($Elements)*10000
End for
End if
DOM EXPORT TO VAR(This.racineXML; $dataTexte)
DOM CLOSE XML(This.racineXML)
// supprimer la balise <?xml >
$dataTexte:=Substring($dataTexte; Position("<"; $dataTexte; 2; *))
$result:=New object("resultat"; Char(1)+$dataTexte)
Function _EcrireArticle($cheminObjet : Text; $nomObjet : Text)
// de l'objet chemin $cheminObjet et de nom $nomObjet dans la structure this.racineXML
var $ElémentXML : Text
// créer l'article
$ElémentXML:=DOM Create XML element(This.racineXML; "article"; "id"; $nomObjet)
// écrire le nom complet de la méthode
This._EcrireNomMéthode($cheminObjet; $ElémentXML)
// écrire les propriétés de la méthode
This._EcrirePropriétésMéthode($cheminObjet; $ElémentXML)
// écrire le texte de la méthode
This._EcrireTexteMéthode($cheminObjet; $ElémentXML)
Function _EcrireNomMéthode($cheminObjet : Text; $articleXML : Text)
// de la méthode $cheminObjet dans $ElémentXML
var $dataTexte; $nomObjet; $nomObjetForm : Text
var $RacineXML; $ElémentXML : Text
var $typeObjet : Integer
var $ptrTable : Pointer
var $date : Date
var $heure : Time
If ($cheminObjet="@[class]/@")
$dataTexte:=Replace string($cheminObjet; "/"; "")
Else
If ($cheminObjet="@[class]/@")
$dataTexte:=Replace string($cheminObjet; "/"; "")
Else
METHOD RESOLVE PATH($cheminObjet; $typeObjet; $ptrTable; $nomObjet; $nomObjetForm; *)
// créer des sous pour les objets d'un formulaire
Case of
: (($typeObjet=Path project method) | ($typeObjet=Path database method))
$dataTexte:=$nomObjet
: ($typeObjet=Path trigger)
$dataTexte:="["+Table name($ptrTable)+"]trigger"
: (($typeObjet=Path project form) | ($typeObjet=Path table form))
$dataTexte:=$nomObjet
If (Is nil pointer($ptrTable))
$dataTexte:="[ ]"+$dataTexte
Else
$dataTexte:="["+Table name($ptrTable)+"]"+$dataTexte
End if
$dataTexte:=$dataTexte+(" - objet "+$nomObjetForm*Num(Not($nomObjetForm="")))
: ($typeObjet=Path class)
$dataTexte:=Replace string($cheminObjet; "/"; "")
End case
End if
End if
METHOD GET MODIFICATION DATE($cheminObjet; $date; $heure; *)
$dataTexte:=$dataTexte+" - "+String($date; Internal date short)+" "+String($heure; System date short)
If (Asserted($dataTexte#""; Current method name+" : pas d'élémentXML formulaire à création d'un élémentXML objet formulaire"))
$RacineXML:=DOM Create XML element($articleXML; "h2")
$ElémentXML:=DOM Create XML element($RacineXML; "a") // pour le retour au menu
DOM SET XML ATTRIBUTE($ElémentXML; "href"; "#"; "class"; "retour")
$ElémentXML:=DOM Create XML element($ElémentXML; "span")
DOM SET XML ELEMENT VALUE($ElémentXML; Char(0x21E7)) // flèche vers le haut
DOM SET XML ELEMENT VALUE($RacineXML; $dataTexte)
End if
Function _EcrirePropriétésMéthode($cheminObjet : Text; $articleXML : Text)
// de la méthode $cheminObjet dans $articleXML
var $typeObjet : Integer
var $Attributs : Object
var $c : Collection
var $RacineXML; $ElémentXML; $attribut : Text
If ($cheminObjet="@[class]/@")
// pas de propriétés (4Dv20R7)
Else
$typeObjet:=This._LireTypeObjetDeChemin($cheminObjet)
If ($typeObjet=Path project method)
METHOD GET ATTRIBUTES($cheminObjet; $Attributs; *)
$c:=New collection
If (OB Get($Attributs; "shared"))
$c.push("Partagée entre composants et base hôte")
End if
If (OB Get($Attributs; "publishedSoap"))
$c.push("Offerte comme Web Service")
End if
If (OB Get($Attributs; "publishedSql"))
$c.push("Disponible via SQL")
End if
If (OB Get($Attributs; "publishedWeb"))
$c.push("Disponible via les balises HTML et les URLs 4D (4DACTION...)")
End if
If (OB Get($Attributs; "publishedWsdl"))
$c.push("Publiée dans WSDL")
End if
If (OB Get($Attributs; "preemptive")="capable")
$c.push("Capable de process préemptif")
End if
If ($c.length>0)
$RacineXML:=DOM Create XML element($articleXML; "h4")
For each ($attribut; $c)
$ElémentXML:=DOM Create XML element($RacineXML; "p")
DOM SET XML ELEMENT VALUE($ElémentXML; $attribut)
End for each
End if
End if
End if
Function _EcrireTexteMéthode($cheminObjet : Text; $articleXML : Text)
// de la méthode $cheminObjet dans $articleXML
var $dataTexte; $ElémentXML : Text
If (Is compiled mode(*))
$dataTexte:="Code de la méthode non disponible (base compilée)"
Else
METHOD GET CODE($cheminObjet; $dataTexte; 0; *)
$dataTexte:=Substring($dataTexte; Position(Char(Carriage return); $dataTexte)+1) // virer le commentaire 4D
If ($dataTexte="")
$dataTexte:="Pas de code"
End if
$dataTexte:=Replace string($dataTexte; Char(Carriage return); "\n") // v16.2 \r n'est plus le RC des navigateur HTML (?) \n est mieux
End if
$ElémentXML:=DOM Create XML element($articleXML; "pre") // avec cette balise, l'affichage par Safari du code source de la page est plus rapide (NON)
$ElémentXML:=DOM Create XML element($ElémentXML; "code")
DOM SET XML ELEMENT VALUE($ElémentXML; $dataTexte)
// ----------------------
// MARK:Menus
// ----------------------
Function _CréerBarreMenus($fichier : 4D.File; $nomTemplate : Text)
// créer la barre de menu de la page $url dans le fichier $fichier
var $template : 4D.File
$template:=Folder(fk resources folder).folder("TemplatesPagesWeb").file($nomTemplate)
This._TraiterBalise4D($template; $fichier)
Function _SupprimerSousDossiers($nomObjet : Text; $c : Pointer)
// supprimer dans $c les chemins contenant '_' (sous dossiers)
var $cc : Collection
$cc:=$c->copy()
$c->:=$cc.filter(Formula(Position($2; $1.value)=0); $nomObjet)
Function _EcrireDossiersTdM($url : Text; $RacineXML : Text; $chemin : Text)
// du dossier $chemin dans $RacineXMLlocal, $url = niveau LH
var $RacineXMLlocal; $ElémentXML; $nomObjet : Text
var $i : Integer
var $c : Collection
$RacineXMLlocal:=DOM Create XML element($RacineXML; "li")
$ElémentXML:=DOM Create XML element($RacineXMLlocal; "a"; "href"; "#"; "class"; "sousListeN")
// récupérer le nom du dossier (dernier mot-clé)
$i:=Position(" "; $chemin; $i)
DOM SET XML ELEMENT VALUE($ElémentXML; Substring($chemin; $i+1))
// créer une sous liste
$ElémentXML:=DOM Create XML element($RacineXMLlocal; "ul")
// lister les sous-dossiers de $chemin
$nomObjet:=Substring($chemin; 1; $i-1) // ID du dossier
ARRAY TEXT($Elements; 0)
METHOD GET FOLDERS($Elements; $nomObjet+"_@"; *)
$c:=New collection
ARRAY TO COLLECTION($c; $Elements)
If ($c.length>0) // il y a des sous dossiers
// lister les sous sous dossiers
$c.sort()
This._SupprimerSousDossiers($nomObjet+"_@_"; ->$c)
For each ($chemin; $c)
// rappel : il n'y a pas de sous dossiers; garder le même path $4
This._EcrireDossiersTdM($url; $ElémentXML; $chemin)
End for each
Else
// écrire la liste des objets de ce sous dossier
This._EcrireEntréesTdM($url; $ElémentXML; $chemin)
End if
Function _EcrireEntréesTdM($url : Text; $RacineXML : Text; $path : Text)
// du dossier $chemin dans $RacineXML, lien au chemin $url
var $ElémentXML; $chemin; $dataTexte; $nomObjet; $nomObjetForm : Text
var $typeObjet : Integer
var $ptrTable : Pointer
var $c : Collection
var $i : Integer
For ($i; 0; 5) //boucle sur les 5 types d'objets ()
ARRAY TEXT($Elements; 0)
METHOD GET PATHS($path; 0 ?+ $i; $Elements; *)
$c:=New collection
ARRAY TO COLLECTION($c; $Elements)
$c.sort()
If ($c.length>0)
For each ($chemin; $c)
If ($chemin="@[class]/@")
$dataTexte:=Replace string($chemin; "/"; "")
$ElémentXML:=DOM Create XML element($RacineXML; "li")
Else
METHOD RESOLVE PATH($chemin; $typeObjet; $ptrTable; $nomObjet; $nomObjetForm; *)
// créer des sous pour les objets d'un formulaire
Case of
: (($typeObjet=Path project method) | ($typeObjet=Path database method))
$dataTexte:=$nomObjet
$ElémentXML:=DOM Create XML element($RacineXML; "li")
: ($typeObjet=Path class)
$dataTexte:=Replace string($chemin; "/"; "")
$ElémentXML:=DOM Create XML element($RacineXML; "li")
: (($typeObjet=Path project form) | ($typeObjet=Path table form))
// essayer une méthode formulaire
If ($nomObjetForm="")
$dataTexte:=$nomObjet
If (Is nil pointer($ptrTable))
$dataTexte:="[ ]"+$dataTexte
Else
$dataTexte:="["+Table name($ptrTable)+"]"+$dataTexte
End if
$ElémentXML:=DOM Create XML element($RacineXML; "li")
// c'est une méthode objet de formulaire
Else
//chercher la méthode formulaire
$dataTexte:=Replace string($chemin; "/"+$nomObjetForm; "/{formMethod}")
$ElémentXML:=DOM Find XML element by ID($RacineXML; "menu-"+This.fct.FormaterNomXML($dataTexte))
If (ok=0)
// cas d'une méthode objet dont le formulaire n'a pas de méthode
$ElémentXML:=DOM Create XML element($RacineXML; "ul")
// 07/04/2025 DOM SET XML ELEMENT VALUE($ElémentXML; $nomObjet)
End if
// chercher la sous liste des objets
If (DOM Count XML elements($ElémentXML; "ul")>0)
// 07/04/2025 $ElémentXML:=DOM Find XML element($ElémentXML; "li/ul")
// 07/04/2025 $ElémentXML:=DOM Find XML element($ElémentXML; "ul")
Else
// 07/04/2025 $ElémentXML:=DOM Create XML element($ElémentXML; "ul") // sous liste d'objets
End if
$ElémentXML:=DOM Create XML element($ElémentXML; "li")
$dataTexte:=$nomObjetForm
End if
: ($typeObjet=Path trigger)
$dataTexte:="["+Table name($ptrTable)+"]trigger"
$ElémentXML:=DOM Create XML element($RacineXML; "li")
End case
End if
// remarque : ici on ne peut pas avoir de méthode base
If (Asserted($ElémentXML#""; Current method name+" : pas d'élémentXML formulaire à création d'un élémentXML objet formulaire"))
$nomObjet:=This._FixerNomObjet($chemin)
DOM SET XML ATTRIBUTE($ElémentXML; "id"; "menu-"+$nomObjet)
$ElémentXML:=DOM Create XML element($ElémentXML; "a")
DOM SET XML ATTRIBUTE($ElémentXML; "href"; $url+"#"+$nomObjet)
DOM SET XML ELEMENT VALUE($ElémentXML; $dataTexte)
End if
End for each
End if
End for
Function _EcrireMéthodesBase($url : Text; $racineXML : Text)
// dans $racineXML, chemin $url
var $c : Collection
var $nomObjet; $chemin; $ElémentXML : Text
ARRAY TEXT($Elements; 0)
METHOD GET PATHS(2; $Elements; *)
$c:=New collection
ARRAY TO COLLECTION($c; $Elements)
For each ($chemin; $c)
$ElémentXML:=DOM Create XML element($racineXML; "li")
$nomObjet:=This._FixerNomObjet($chemin)
DOM SET XML ATTRIBUTE($ElémentXML; "id"; "menu-"+$nomObjet)
$ElémentXML:=DOM Create XML element($ElémentXML; "a")
DOM SET XML ATTRIBUTE($ElémentXML; "href"; $url+"#"+$nomObjet)
$nomObjet:=This._LireNomObjetDeChemin($chemin)
DOM SET XML ELEMENT VALUE($ElémentXML; $nomObjet)
End for each
// ----------------------
// MARK:Chemins propres à l'export
// ----------------------
Function _FixerNomObjet($cheminMethode : Text)->$result : Text
// créer un nom non ambigue (id) quel que soit le type d'objet
var $dataTexte; $nomObjet; $nomObjetForm : Text
var $typeObjet : Integer
var $ptrTable : Pointer
If ($cheminMethode="@[class]/@")
$dataTexte:=Replace string($cheminMethode; "[class]/"; "")
Else
METHOD RESOLVE PATH($cheminMethode; $typeObjet; $ptrTable; $nomObjet; $nomObjetForm; *)
// balayer tous les cas
Case of
: ($typeObjet=Path project method)
$dataTexte:=$nomObjet
: ((($typeObjet=Path project form) | ($typeObjet=Path table form)) & ($nomObjetForm=""))
$dataTexte:=$nomObjet
: (($typeObjet=Path project form) | ($typeObjet=Path table form))
$dataTexte:=$nomObjet+"-"+$nomObjetForm
: ($typeObjet=Path database method)
$dataTexte:=This._NomFichierExport+"-"+$nomObjet
: ($typeObjet=Path trigger)
// attention : hypothèse que 2 tables de l'applcation complète n'ont pas le même nom
$dataTexte:=Table name($ptrTable)
: ($typeObjet=Path class)
$dataTexte:=Replace string($cheminMethode; "[class]/"; "")
End case
End if
$result:=This.fct.FormaterHTML($dataTexte)
Function _FixerDossierExport()->$result : 4D.Folder
// les pages sont dans un dossier au niveau du fichier structure
$result:=This.document.getStructureFolder().parent.folder(This._NomDossierExport)
Function get _NomDossierExport()->$result : Text
$result:="ALV_Code"
Function get _NomDossierExportComposant()->$result : Text
$result:="Components_Code"
Function get _NomComposant()->$result : Text
// récupérer le nom de la base courante
var $dossier : 4D.Folder
$dossier:=This.document.getStructureFolder()
$result:=Replace string($dossier.name; ".4dbase"; "")
Function get _NomFichierExport()->$result : Text
// récupérer le nom regexé de la base
$result:=This._NomComposant
$result:=This.fct.FormaterHTML($result)
Function get _NomFichierMenu()->$result : Text
$result:="Menus_"+This._NomFichierExport+".html"
// ----------------------
// MARK:Utilitaires
// ----------------------
Function _LireTypeObjetDeChemin($cheminObjet)->$result : Integer
var $typeObjet : Integer
var $ptrTable : Pointer
var $nomObjet; $nomObjetForm : Text
METHOD RESOLVE PATH($cheminObjet; $typeObjet; $ptrTable; $nomObjet; $nomObjetForm; *)
$result:=$typeObjet
Function _LireNomObjetDeChemin($cheminObjet)->$result : Text
var $typeObjet : Integer
var $ptrTable : Pointer
var $nomObjet; $nomObjetForm : Text
METHOD RESOLVE PATH($cheminObjet; $typeObjet; $ptrTable; $nomObjet; $nomObjetForm; *)
$result:=$nomObjet
Function _TraiterBalise4D($fichierIN : 4D.File; $fichierOUT : 4D.File)->$result : cs.Traces
var $texteBlobé : 4D.Blob
var $dataTexte : Text
$result:=cs.Traces.new().CréerErreur("SDK"; -16004; Current method name; "Le template "+$fichierIN.fullName+" n'existe pas")
If ($fichierIN.exists)
$texteBlobé:=$fichierIN.getContent()
$result.Error:=-16003*Num($texteBlobé.size=0)
$result.ErrorDescription:="le fichier "+$fichierIN.fullName+" n'est pas chargé"
If ($result.Error=0)
// ouvrir le contenu
$dataTexte:=BLOB to text($texteBlobé; UTF8 text without length)
PROCESS 4D TAGS($dataTexte; $dataTexte)
// enregistrer le contenu modifié
$texteBlobé:=4D.Blob.new()
CONVERT FROM TEXT($dataTexte; "UTF-8"; $texteBlobé)
$fichierOUT.setContent($texteBlobé)
$result.Error:=-16003*Num($fichierOUT.size=0)
$result.ErrorDescription:="le fichier "+$fichierOUT.fullName+" n'est pas créé (vide)"
End if
End if
Function _TraiterBaliseALV($fichierIN : 4D.File; $fichierOUT : 4D.File)->$result : cs.Traces
var $texteBlobé : 4D.Blob
var $dataTexte : Text
$result:=cs.Traces.new().CréerErreur("SDK"; -16004; Current method name; "Le template "+$fichierIN.fullName+" n'existe pas")
If ($fichierIN.exists)
$texteBlobé:=$fichierIN.getContent()
$result.Error:=-16003*Num($texteBlobé.size=0)
$result.ErrorDescription:="le fichier "+$fichierIN.fullName+" n'est pas chargé"
If ($result.Error=0)
// ouvrir le contenu
$dataTexte:=BLOB to text($texteBlobé; UTF8 text without length)
// transformer les balise ALV en balise 4D
$dataTexte:=Replace string($dataTexte; "#4D"; "#4D")
// traiter les balises
PROCESS 4D TAGS($dataTexte; $dataTexte)
// enregistrer le contnu modifié
$texteBlobé:=4D.Blob.new()
CONVERT FROM TEXT($dataTexte; "UTF-8"; $texteBlobé)
$fichierOUT.setContent($texteBlobé)
$result.Error:=-16003*Num($fichierOUT.size=0)
$result.ErrorDescription:="le fichier "+$fichierOUT.fullName+" n'est pas créé (vide)"
End if
End if
// ----------------------
// MARK:Git
// ----------------------
Function _DéposerDansDossierGit()
// aller au repository
var $dossierDestination; $dossierSource : 4D.Folder
var $c : Collection
var $fichier : 4D.File
// dossier du repository
$dossierDestination:=Null
// dossier des fichiers code 4D
$dossierSource:=Folder(Structure file(*); fk platform path).parent.folder("Sources")
Case of
: (Not(This._getFolderGit(->$dossierDestination)))
: ($dossierDestination.isFolder=False)
: ($dossierSource.isFolder=False)
// pas de projet (ancienne architecture)
Else
// chemin des fichiers sources
$dossierDestination:=$dossierSource.copyTo($dossierDestination; $dossierSource.parent.parent.name; fk overwrite)
// nettoyer
$c:=New collection(".4Dsettings"; ".css"; ".4DCatalog")
For each ($fichier; $dossierDestination.files(fk recursive+fk ignore invisible))
If ($c.indexOf($fichier.extension)>-1)
$fichier.delete()
End if
End for each
End case
Function _getFolderGit($ptrDossier : Pointer)->$result : Boolean
// rechercher sur le volume un dossier de nom ressource"DepotGit"
var $dataTexte : Text:=""
var $dossier : 4D.Folder
// nom du dossier Git :
$dataTexte:=Localized string("100")
// chemin du dossier du composant COURANT (rappel : l'export est fait par le ALV_sdk installé dans le composant courant)
$dossier:=Folder(Path to object(Get 4D folder(Database folder; *); Path is system).parentFolder; fk platform path)
$result:=False
Repeat
Case of
: ($dossier=Null)
// pas touvé
$dossier:=Folder(fk documents folder).folder($dataTexte)
$dossier.create()
$ptrDossier->:=$dossier
$result:=True
Else
If ($dossier.folders().query("name = :1"; $dataTexte).length>0) //Find in array($Elements; $dataTexte)>0)
// trouvé
$ptrDossier->:=$dossier.folder($dataTexte)
$result:=True
Else
// reboucler
$dossier:=$dossier.parent
End if
End case
Until ($result)
//Function _InitialiserFolderGit()
//var $dossier : 4D.Folder
//var $commande; $stdIn; $stdOut; $stdErreurs : Text
//$dossier:=Null
//Case of
//: (This._getFolderGit(->$dossier)#0)
//: (Request("Initialiser le dépôt dans "; $dossier.path)#$dossier.path)
//Else
//// c'est ok
//$stdIn:=""
//$stdOut:=""
//$stdErreurs:=""
//$commande:="git init"
//SET ENVIRONMENT VARIABLE("_4D_OPTION_CURRENT_DIRECTORY"; $dossier) // doit être équivalent à une commande UNIX "cd ..." ?
//LAUNCH EXTERNAL PROCESS($commande; $stdIn; $stdOut; $stdErreurs)
//SET ENVIRONMENT VARIABLE("_4D_OPTION_CURRENT_DIRECTORY"; "")
//If ($stdErreurs="")
//LAUNCH EXTERNAL PROCESS("open -a GitUp")
//End if
//End case
⇧
[class]RegistreTaches - 11/05/2026 13:13:41
property registre : Collection
shared singleton Class constructor()
This.registre:=New shared collection
Function Inscrire($params : Object)->$result : Object
var $tache : cs.Tache
$result:=Null
Case of
: (Not(This.ParamètresValides($params)))
: (This.existeTache($params.nomTache))
$result:=This.LireTache($params.nomTache)
cs.Traces.new().EnvoyerMessages([msgk_event; msgk_log]; "SDK"; "WARNING registre des tâches"; Current method name; "Ré utilisation de la tâche existante '"+$params.nomTache+"'")
Else
// ajouter une tache
$tache:=cs.Tache.new()
Use (This.registre)
This.registre.push(OB Copy($tache; ck shared))
End use
$result:=This.registre.last()
// on peut modifier l'objet partagé
$result.Initialiser($params)
End case
Function DésInscrire($nomTache : Text)
// retirer This de la liste partagée
// ici, on est dans un worker (ou process externe?) qui indique au process appelant que la tâche est terminée
// ou, on est dans le process réalisant la tâche inscrite et terminée
var $c : Collection
// attention c'est subtil : si la tâche est très rapide, elle peut se déinscrire avant d'être inscrite
// on attend un peu
Waiting(3)
Case of
: (This.registre=Null)
: (This.registre.length=0)
// pas de taches en cours
Else
// chercher la tâche This
$c:=This.registre.query("nomTache = :1"; $nomTache)
If ($c.length=1)
Use (This.registre)
This.registre:=This.registre.remove(This.registre.indexOf($c[0]))
End use
End if
End case
Function Tuer($origine : Variant)
var $c : Collection
var $tache : cs.Tache
var $nomProcess : Text
var $numProc : Integer
// lister les tâches à tuer
Case of
: (This.registre=Null)
: (This.registre.length=0)
// rien à tuer
: (Value type($origine)=Is text)
// lister toutes les tâches de nom commençant par $origine
$nomProcess:=$origine // retypage
$c:=This.registre.query("nomTache = :1"; $nomProcess+"@")
: (Value type($origine)=Is longint)
// lister toutes les tâches du process numéro $origine
$numProc:=$origine // retypage
$c:=This.registre.query("numProcessAppelant = :1"; $numProc)
End case
If ($c.length>0)
// tuer chaque tâche
For each ($tache; $c)
$tache.Tuer.trigger()
This.DésInscrire($tache.nomTache)
End for each
// rappel : dans le cas normal, une tâche est tuée par X et le process qui l'utilise la déinscrit
End if
Function ParamètresValides($params : Object)->$result : Boolean
var $erreur : cs.Traces
$erreur:=cs.Traces.new().CréerErreur("SDK"; -15068; Current method name; "")
Case of
: (Not(OB Is defined($params; "nomTache")))
$erreur.ErrorDescription:="Le paramètre 'nomTache' n'est pas défini dans $params"
: (Not(OB Is defined($params; "nomProcess")))
$erreur.ErrorDescription:="Le paramètre 'nomProcess' n'est pas défini dans $params"
: (Not(OB Is defined($params; "numProcessAppelant")))
$erreur.ErrorDescription:="Le paramètre 'numProcessAppelant' n'est pas défini dans $params"
// ça démarre fort !
Else
$erreur.Error:=0
End case
$erreur.FixerSuccess()
$erreur.LeverException([msgk_event; msgk_log])
$result:=$erreur.success
//----------------------
//MARK:Appel extérieur
//----------------------
Function LireInscriptions()->$result : Collection
var $tache : Object
$result:=Null
Case of
: (This.registre=Null)
: (This.registre.length=0)
Else
// faire une copie simple
$result:=New collection
For each ($tache; This.registre)
$result:=$result.push($tache)
End for each
End case
Function existeTache($nomTache : Text)->$result : Boolean
$result:=(This.LireTache($nomTache)#Null)
Function LireTache($nomTache : Text)->$result : cs.Tache
var $c : Collection
$result:=Null
Case of
: (This.registre=Null)
: (This.registre.length=0)
Else
$c:=This.registre.query("nomTache = :1"; $nomTache)
// dans cette version, une seule !
Case of
: ($c.length=1)
$result:=$c[0]
: ($c.length>1)
cs.Traces.new().EnvoyerMessages([msgk_event; msgk_log]; "SDK"; "WARNING registre des tâches"; Current method name; "Il existe "+String($c.length)+" enregistrements de la tâche '"+$nomTache+"'")
End case
End case
⇧
[class]$FileTransfer_curl - 28/05/2025 18:12:44
property _host; _user; _password; _protocol; _return; _range; _prefix; _curlPath; _CallbackID; _ActiveModeIP : Text
property onData : Object
property _noProgress; _AutoCreateRemoteDir; _AutoCreateLocalDir; _async; _ActiveMode : Boolean
property _timeout; _connectTimeout; _maxTime : Integer
property _Callback : 4D.Function
property _enableStopButton : Object
property _worker : 4D.SystemWorker
Class constructor($hostname : Text; $username : Text; $password : Text; $protocol : Text)
var $col : Collection
ASSERT(Length($hostname)>0; "Hostname must not be empty")
If ($protocol="")
$protocol:="ftp-ftps"
End if
$col:=New collection("ftp"; "ftps"; "sftp"; "ftp-ftps"; "https"; "http")
ASSERT($col.indexOf($protocol)>=0; "Unsupported protocol")
This._host:=$hostname
This._user:=$username
This._password:=$password
This._protocol:=$protocol
This.onData:=New object("text"; "")
This._noProgress:=True
If (Is macOS)
This._return:=Char(10)
Else
This._return:=Char(10) //Char(13)+Char(10)
End if
This._timeout:=0
This._enableStopButton:=New shared object("stop"; False)
//MARK: Settings
Function validate()->$success : Object
var $url : Text
$url:=This._buildURL()
$url+="/"
$success:=This._runWorker($url)
If ($success.success=True)
$success.data:=Null // not needed for checking...
End if
Function version()->$data : Object
$data:=This._runWorker("-V")
Function setConnectTimeout($seconds : Real)
// sets --connect-timeout <seconds>
This._connectTimeout:=$seconds
Function setMaxTime($seconds : Real)
// sets -m, --max-time <seconds>
This._maxTime:=$seconds
Function setAutoCreateRemoteDirectory($auto : Boolean)
This._AutoCreateRemoteDir:=$auto
Function setAutoCreateLocalDirectory($auto : Boolean)
This._AutoCreateLocalDir:=$auto
Function setActiveMode($active : Boolean; $IP : Text)
// pass emtpy to switch back to passive (default moe)
// pass IP address or "-" for default IP for FTP to connect back
This._ActiveMode:=$active
If ($active)
If ($IP="")
$IP:="-"
End if
This._ActiveModeIP:=$IP
End if
Function setTimeout($timeout : Integer)
This._timeout:=$timeout
Function setAsyncMode($async : Boolean)
This._async:=$async
Function setRange($range : Text)
// 0-99 or -500 (last 500) , 500- (starting with 500 till end)
This._range:=$range
Function setCurlPrefix($prefix : Text)
// allows to set any parameters directly after curl
This._prefix:=$prefix
Function setPath($path : Text)
This._curlPath:=$path
Function enableProgressData($enable : Boolean)
This._noProgress:=Not($enable)
Function enableStopButton($enable : Object) // this is a shared object!
This._enableStopButton:=$enable
Function useCallback($callback : 4D.Function; $ID : Text)
ASSERT(Value type($callback)=Is object; "Callback must be of type function")
ASSERT(OB Instance of($callback; 4D.Function); "Callback must be of type function")
ASSERT($ID#""; "Callback ID Method must not be empty")
This._Callback:=$callback
This._CallbackID:=$ID
This._noProgress:=False
//MARK: FileTransfer
Function upload($sourcepath : Text; $targetpath : Text; $append : Boolean)->$success : Object
//$sourcepath just file name for local directory, else full path in POSIX syntax
// targetpath is remote path. / for same name as local file in default dir, else /dir/ or /dir/newname.txt
// append: (FTP SFTP) When used in an upload, this makes curl append to the target file instead of overwriting it.
// If the remote file does not exist, it will be created.
// Note that this flag is ignored by some SFTP servers (including OpenSSH).
var $url; $doublequotes : Text
var $oldtimeout : Integer
ASSERT(Length($sourcepath)>0; "source path must not be empty")
$doublequotes:=Char(Double quote)
If ($targetpath="")
$targetpath:="/"
End if
$url:=This._buildURL()
If ($append)
$url:="--append "+$url
End if
If ((This._AutoCreateRemoteDir#Null) && (This._AutoCreateRemoteDir))
$url:="--ftp-create-dirs "+$url
End if
$url:="-T "+$doublequotes+$sourcepath+$doublequotes+" "+$url+$targetpath
$oldtimeout:=This._timeout
If ($oldtimeout=0)
This._timeout:=600
End if
$success:=This._runWorker($url)
This._timeout:=$oldtimeout
This._parseFileListing($success)
Function download($sourcepath : Text; $targetpath : Text)->$success : Object
/* supports
"ftp://ftp.example.com/file[1-100].txt"
"ftp://ftp.example.com/file[001-100].txt" (with leading zeros)
"ftp://ftp.example.com/file[a-z].txt"
"ftp://example.com/file[1-100:10].txt" (steps 10)
target needs to be folder, ending with /
*/
var $url : Text
var $oldtimeout : Integer
ASSERT(Length($sourcepath)>0; "source path must not be empty")
ASSERT(Length($targetpath)>0; "target path must not be empty")
$url:=This._buildURL()
If ((This._AutoCreateLocalDir#Null) && (This._AutoCreateLocalDir))
$url:=" --create-dirs "+$url
End if
If ($targetpath="@/")
$url:=" --output-dir "+$targetpath+" --remote-name-all "+$url+$sourcepath
Else
$url:=" -o "+$targetpath+" "+$url+$sourcepath
End if
$oldtimeout:=This._timeout
If ($oldtimeout=0)
This._timeout:=600
End if
$success:=This._runWorker($url)
This._timeout:=$oldtimeout
This._parseFileListing($success)
Function getDirectoryListing($targetpath : Text)->$success : Object
var $url : Text
If ($targetpath="")
$targetpath:="/"
End if
$url:=This._buildURL()+$targetpath
$success:=This._runWorker($url)
If ($success.success)
// data contains a text based dir listing
This._parseDirListing($success)
End if
Function createDirectory($targetpath : Text)->$success : Object
var $url : Text
ASSERT(Length($targetpath)>0; "target path must not be empty")
$url:=This._buildURL()
$url:=$url+$targetpath+" --ftp-create-dirs"
$success:=This._runWorker($url)
// only empty directories can be deleted!
Function deleteDirectory($targetpath : Text)->$success : Object
var $url : Text
ASSERT(Length($targetpath)>0; "target path must not be empty")
$url:=This._buildURL()
If (This._protocol#"SFTP")
$url:=$url+" -Q "+Char(34)+"RMD "+$targetpath+Char(34)
Else
$url:=$url+" -Q "+Char(34)+"-RMDIR "+$targetpath+Char(34)
End if
$success:=This._runWorker($url)
If ($success.success)
// data contains a text based dir listing
This._parseDirListing($success)
End if
// only empty directories can be deleted!
Function deleteFile($targetpath : Text)->$success : Object
var $url : Text
ASSERT(Length($targetpath)>0; "target path must not be empty")
$url:=This._buildURL()
If (This._protocol#"SFTP")
$url:=$url+" -Q "+Char(34)+"DELE "+$targetpath+Char(34)
Else
$url:=$url+" -Q "+Char(34)+"-RM "+$targetpath+Char(34)
End if
$success:=This._runWorker($url)
If ($success.success)
// data contains a text based dir listing
This._parseDirListing($success)
End if
Function renameFile($sourcepath : Text; $targetpath : Text)->$success : Object
var $url : Text
ASSERT(Length($sourcepath)>0; "source path must not be empty")
ASSERT(Length($targetpath)>0; "target path must not be empty")
$url:=This._buildURL()
If (This._protocol#"SFTP")
$url:=$url+" -Q "+Char(34)+"-RNFR "+$sourcepath+Char(34)+" -Q "+Char(34)+"-RNTO "+$targetpath+Char(34)
Else
$url:=$url+" -Q "+Char(34)+"-RENAME "+$sourcepath+Char(34)+" "+$targetpath+Char(34)
End if
$success:=This._runWorker($url)
If ($success.success)
// data contains a text based dir listing
// this is the list BEFORE renaming
This._parseDirListing($success)
End if
Function executeCommand($command : Text) : Object
ASSERT(Length($command)>0; "command must not be empty")
return This._runWorker($command)
Function stop()
If (This._worker#Null)
This._worker.terminate()
End if
Function status()->$status : Object
$status:=New object
$status.terminated:=This._worker.terminated
$status.response:=This._worker.response
$status.responseError:=This._worker.responseError
$status.exitCode:=This._worker.exitCode
$status.errors:=This._worker.errors
Function wait($max : Integer)
This._worker.wait($max)
// MARK: Internal helper calls
Function _parseDirListing($success : Object)
var $col; $lineitems; $datecol : Collection
var $line : Text
var $diritem : Object
var $year; $month; $day : Integer
var $time : Time
$col:=Split string(String($success.data); This._return; sk ignore empty strings)
$success.list:=New collection
For each ($line; $col)
$line:=Replace string($line; Char(13); "")
$lineitems:=Split string($line; " "; sk trim spaces+sk ignore empty strings)
$diritem:=New object
If ($lineitems.length>=9)
$diritem.access:=$lineitems[0]
$diritem.type:=$lineitems[1]
$diritem.owner:=$lineitems[2]
$diritem.group:=$lineitems[3]
$diritem.size:=$lineitems[4]
$datecol:=New collection("Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec")
$month:=$datecol.indexOf($lineitems[5])+1
$day:=Num($lineitems[6])
If (Substring($lineitems[7]; 3; 1)=":")
$year:=Year of(Current date)
$time:=Time($lineitems[7])
Else
$year:=Num($lineitems[7])
$time:=?00:00:00?
End if
$diritem.date:=Add to date(!00-00-00!; $year; $month; $day)
$diritem.time:=$time
$diritem.path:=($lineitems.slice(8).join(" "))
$success.list.push($diritem)
Else // error?
If ($col.length=1)
$success.success:=False
$success.responseError:="Directory listing unexpected format"
Else
$success.list.push(New object("line"; $line))
End if
End if
End for each
Function _parseFileListing($success : Object)
var $col : Collection
var $line : Text
$col:=Split string(String($success.data); This._return; sk ignore empty strings)
$success.list:=New collection
For each ($line; $col)
$line:=Replace string($line; Char(13); "")
If ($line="--_curl_--@")
$success.list.push(New object("file"; Substring($line; 11)))
End if
End for each
Function _buildURL()->$url : Text
Case of
: ((This._protocol="ftps") | (This._protocol="ftp") | (This._protocol="ftp-ftps"))
If (This._user#"")
$url:="--user \""+This._user+":"+This._password+"\" ftp://"
Else
$url:="ftp://"
End if
$url+=This._host
Case of
: (This._protocol="ftps")
$url:="--ftp-ssl-reqd "+$url
: (This._protocol="ftp-ftps")
$url:="--ftp-ssl "+$url
End case
: (This._protocol="sftp")
$url:="sftp://"
If (This._user#"")
$url+=This._user+":"+This._password+"@"
End if
$url+=This._host
: ((This._protocol="https") | (This._protocol="http"))
$url:=This._protocol+"://"
If (This._user#"")
$url+=This._user+":"+This._password+"@"
End if
$url+=This._host
Else
ASSERT(True; "unsupported protocol")
End case
Function _runWorker($para : Text)->$result : Object
var $workerpara : cs.$SystemWorkerProperties
var $path; $command; $old : Text
var $worker : Object
var $waittimeout; $pos : Integer
If (This._Callback#Null)
$workerpara:=cs.$SystemWorkerProperties.new("curl"; This.onData; This._Callback; This._CallbackID; This._enableStopButton)
Else
$workerpara:=cs.$SystemWorkerProperties.new("curl"; This.onData)
End if
If ((This._curlPath) && (This._curlPath#""))
$path:=This._curlPath
Else
$path:="curl"
End if
$path+=" -f" // failure report
If ((This._noProgress#Null) && (This._noProgress))
$path+=" --no-progress-meter"
End if
If (This._connectTimeout#Null)
$path+=" --connect-timeout "+String(This._connectTimeout)
End if
If (This._maxTime#Null)
$path+=" --max-time "+String(This._maxTime)
End if
If (This._range#Null)
$path+=" --range "+This._range
End if
If ((This._ActiveMode#Null) && (This._ActiveMode)) // default passive
$path+=" --ftp-port "+This._ActiveModeIP
End if
If (This._prefix#Null)
$path+=(" "+This._prefix)
End if
$command:=$path+" "+$para
$old:=Method called on error
ON ERR CALL(Formula(ErrorHandler).source; ek local)
This._worker:=4D.SystemWorker.new($command; $workerpara)
$worker:=This._worker
If ($worker#Null)
If ((This._async#Null) && (This._async))
$result:=New object("data"; "async"; "success"; True)
Else
$waittimeout:=(This._timeout=0) ? 60 : This._timeout
$worker.wait($waittimeout)
If (($worker.responseError#Null) && ($worker.responseError#""))
$result:=New object("responseError"; $worker.responseError; "success"; False)
$pos:=Position("curl: "; $worker.responseError; *)
If ($pos>0)
$result.error:=Replace string(Substring($worker.responseError; $pos+6); Char(10); "")
Else
// seems not to be an error, curl set's process bar in error and no result in response.
If ($worker.response#"")
$result:=New object("data"; $worker.response; "success"; True)
Else
$result:=New object("data"; $worker.responseError; "success"; True)
End if
End if
Else
$result:=New object("data"; $worker.response; "success"; True)
End if
End if
Else
$result:=New object("success"; False; "responseError"; "Curl execution error")
End if
ON ERR CALL($old; ek local)
⇧
[ ]U_Formulaire?Générer Composant - 12/04/2025 18:21:05
Form._TraiterFORMevent()
⇧
[ ]U_Palette?3050 - 17/03/2025 08:57:18
// 2025-03-17 4Dv20R7 tous les Form Event des objet arrivent ici !
Form._TraiterFORMevent()
⇧
[ ]U_Palette?3050 - objet ConstanteType - 16/03/2025 19:32:28
// nécessaire
Form._TraiterFORMevent()
⇧
[ ]Console - 15/04/2025 17:02:04
Form._TraiterFORMevent()
⇧
onStartup - 25/04/2025 14:35:37
// ici, ne s'exécute pas dans une base hôte
ON ERR CALL(Formula(traceHandler).source; ek global)
cs.$composant.new().initVariablesSDK()
// initialiser le worker ALV
CALL WORKER(Worker Services; Formula(InitProcess))
// initialiser le worker des events
CALL WORKER(Worker EvenementsALV; Formula from string("cs.EvenementsALV.new().InitProcess()"))
⇧
onServerStartup - 25/04/2025 13:06:08
Pas de code
⇧
onExit - 02/04/2025 09:21:10
// ne s'exécute pas dans une base hôte
// exporter le code du composant si pas compilé
ON ERR CALL(Formula(traceHandler).source; ek local)
cs.ExportCode4D.new().DémarrerComposant()
⇧
onSystemEvent - 27/11/2022 19:03:56
Pas de code
⇧
onHostDatabaseEvent - 06/02/2026 18:13:40
#DECLARE($numEvent : Integer)
// ici, s'exécute dans une base hôte
// RAPPEL : penser à activer l'option "Exécuter la méthode 'sur évènement base Hôte' des composants qui charge SDK
var $dataBool : Boolean
var $fichier : Object
Case of
: ($numEvent=On before host database startup)
// ici pas d'interaction avec les autres composants et la BDDmère
ON ERR CALL(Formula(ErrorHandler).source; ek local)
// initialiser le worker de services (non thread-safe)
// Rappels :
// le worker peut être appelé par des process préemptif (thread-safe) pour exécuter des méthode non thread-safe
// => il ne peut pas être lui-même préemptif : "InitProcess" NE DOIT PAS avoir la propriété thread-safe (sinon le worker est tagué préemptif)
CALL WORKER(Worker Services; Formula(InitProcess))
// initialiser le worker des events
CALL WORKER(Worker EvenementsALV; Formula from string("cs.EvenementsALV.new().InitProcess()"))
cs.$composant.new().initVariablesSDK()
// test application Serveur WEB (les composants peuvent avoir besoin de l'info APRES l'ouverture de la base hôte)
// ici, AVANT l'ouverture de la base hôte, les ressources de l'APP hôte peuvent ne pas encore être installées
// ne pas utiliser "Lire Ressource ALV (Est Ressource APP" ; lecture bas niveau
$fichier:=Folder(fk resources folder; *).file("Commun.xml")
$dataBool:=False
cs.XML.me.LireLeChemin(->$fichier; "Serveur_Web/IsServeurWeb"; ->$dataBool)
Use (Storage.System)
Storage.System.estServeurWeb:=$dataBool
Storage.System.estExecuteDansHote:=True
End use
// installer les ressources du composant
Partager Ressources("Installer Ressources Composant"; New object("dossier"; Get 4D folder(Current resources folder); "IDnom"; "SDK"))
// les autres composants vont utiliser des ressources de SDK
// => les installer avant l'installation des composants
// chercher si l'exécution est dans l'APP
// lire les méthodes de la base hôté
$dataBool:=cs.EnvironnementALV.new().estExecuteDansAPP()
Use (Storage.System)
Storage.System.estExecuteDansAPP:=$dataBool
End use
cs.$composant.new().Installer()
: ($numEvent=On after host database startup)
// attention : le composant est exécuté dans une base hôte APP ou un autre composant (en debug)
// à faire ici tout est initialisé, en particulier le monde extérieur
ON ERR CALL(Formula(traceHandler).source; ek global)
: ($numEvent=On after host database exit)
// purger les derniers logs
cs.Traces.new()._EnregistrerLogs()
End case