in my Procedure there is the following code line
for i in (select schema_name, table_name, restricted_columns
from GRANTED_TABLES_FOR_ROLE
where restricted_columns = 0) loop
execute immediate 'grant select on ' || i.schema_name || '.' || i.table_name || ' to ROLE_NAME';
end loop;
because i want to create the table "GRANTED_TABLES_FOR_ROLE" earlier in my procudere i can't create the procedure without the "GRANTED_TABLES_FOR_ROLE" existing.
is there any way to make the code above dynamic so i can set a variable for the table "GRANTED_TABLES_FOR_ROLE"?
how i can achieve this?
thanks for your help!
I believe this is a case where you will need to use a dynamic cursor:
DECLARE
TYPE trec IS RECORD
(
schema_name VARCHAR2 (30)
, table_name VARCHAR2 (30)
, restricted_columns VARCHAR2 (30)
);
l_rec trec;
l_sqlstment VARCHAR2 (500)
:= q'[SELECT schema_name, table_name, restricted_columns
FROM <<tablename>>
WHERE restricted_columns = 0 ]';
l_cursor SYS_REFCURSOR;
BEGIN
l_sqlstment :=
REPLACE (l_sqlstment, '<<tablename>>', 'granted_tables_for_role');
OPEN l_cursor FOR l_sqlstatement;
LOOP
FETCH l_cursor INTO l_rec;
EXIT WHEN l_cursor%NOTFOUND;
dbms_outout.put_line (l_rec.schema_name);
dbms_outout.put_line (l_rec.table_name);
dbms_outout.put_line (l_rec.restricted_columns);
EXECUTE IMMEDIATE 'grant select on '
|| l_rec.schema_name
|| '.'
|| l_rec.table_name
|| ' to ROLE_NAME';
END LOOP;
END;
I'm currently stuck in creating two tasks inside of a procedure adding numbers of an array passed to the respective procedure.
My generic package looks like this:
generic
type Item_Type is private;
with function "+"(Left: Item_Type; Right: Item_Type) return Item_Type;
package Parallel_Algorithms is
type Array_Type is array(Natural range <>) of Item_Type;
type Array_Access_Type is access all Array_Type;
procedure Parallel_Sum(Input: Array_Access_Type; Result: out Item_Type);
end Parallel_Algorithms;
I implemented the Parallel_Sum Method the following way, being aware that the implementation is not perfect, nor thread safe.
procedure Parallel_Sum(Input: Array_Access_Type; Result: out Item_Type) is
Loop_Var: Integer:= 0;
task type T;
Task1, Task2 : T;
task body T is
begin
while Loop_Var < Input'Length loop
Result := Result + Input(Loop_Var);
Loop_Var := Loop_Var + 1;
end loop;
end T;
begin
-- Result := Temp;
end Parallel_Sum;
If I now run my main program the output of Result always ends up being something like 1918988326. Considering the elements inside of my array (1,2,3,4) that result is obviously wrong.
I read in another post that non altering an out type may result in undefined behaviour of the respective variable.
What would be the proper way to get the 'real' Result?
Upon looking at the problem more closely I see there are several issues to overcome. The tasks must accumulate their own totals, then those totals must be combined. Adding totals to an unprotected Result variable will produce a race condition which will result in undefined results.
Following is my approach to the problem.
------------------------------------------------------------------
-- Parallel Addition of Array Elements --
------------------------------------------------------------------
generic
type Element_Type is range <>;
package Parallel_Addition is
type Array_Type is array(Natural range <>) of Element_Type;
type Array_Access is access all Array_Type;
task type Adder is
Entry Set_Slice(Low, High : in Natural;
Item : in not null Array_Access);
end Adder;
protected Result is
procedure Accumulate(Item : in Element_Type);
function Report return Element_Type;
private
Sum : Integer := 0;
end Result;
end Parallel_Addition;
package body Parallel_Addition is
-----------
-- Adder --
-----------
task body Adder is
My_Array : Array_Access;
Id_Low, Id_High : Natural;
Sum : Integer := 0;
begin
accept Set_Slice(Low, High : in Natural;
Item : in not null Array_Access) do
Id_Low := Low;
Id_High := High;
My_Array := Item;
end Set_Slice;
for I in Id_Low..Id_High loop
Sum := Sum + Integer(My_Array(I));
end loop;
Result.Accumulate(Element_Type(Sum));
end Adder;
------------
-- Result --
------------
protected body Result is
----------------
-- Accumulate --
----------------
procedure Accumulate (Item : in Element_Type) is
begin
Sum := Sum + Integer(Item);
end Accumulate;
------------
-- Report --
------------
function Report return Element_Type is
begin
return Element_Type(Sum);
end Report;
end Result;
end Parallel_Addition;
------------------------------------------------------------------
-- Parallel_Addition Test --
------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Parallel_Addition;
procedure PA_Test is
package adders is new Parallel_Addition(Natural);
use adders;
Data : aliased Array_Type := (1,2,3,4,5,6,7,8,9,10);
T1, T2 : Adder;
begin
T1.Set_Slice(Low => 0, High => 4, Item => Data'Access);
T2.Set_Slice(Low => 5, High => 9, Item => Data'Access);
loop
if T1'Terminated and then T2'Terminated then
exit;
end if;
end loop;
put_Line("The sum is " & Integer'Image(Result.Report));
end PA_Test;
I am trying to develop a stored procedure within TERADATA to handle and manage exceptions.
The stored procedure should raise the error to the caller, which is an SSIS Package.
I am trying to illustrate this by creating a stored procedure for illustration only.
I have these tables:
Table_A:
- ID INT
- ITEM_NUM INT
- DESC VARCHAR(20)
- CREATE_DTTM VARCHAR(2O)
Table_B:
- ID INT
- ITEM_NUM INT
- DESC VARCHAR(20)
- CREATE_DTTM VARCHAR(2O)
I have two tables that will be inserting data from two SELECT statements.
REPLACE PROCEDURE csTest2()
SQL SECURITY OWNER
BEGIN
DECLARE varErrorMessage char(256);
DECLARE varSQLState char(5);
DECLARE varReturnCode char(5);
DECLARE varRollbackNeededInd char(1); /* transaction mgt */
SET varRollbackNeededInd = 'N';
SET varReturnCode = '00000';
SET varErrorMessage = '';
BEGIN TRANSACTION;
-- USING A SINGLE HANDLER WITH MULTIPLE STATEMENTS
-- PLANING TO CHANGE ERROR MESSAGE IN EACH STATEMENT.
ins6: BEGIN
DECLARE EXIT HANDLER FOR SQLEXCEPTION
H99:Begin
set varSQLState = SQLSTATE;
set varErrorMessage= 'This message should not be displayed'; --
end H99;
-- IMAGINE THAT I AM GETTING THE VALUES AS INPUT PARAMERS IN THE PROCEDURE
INSERT INTO "Table_A"
(ID , ITEM_NUM, DESC, CREATE_DTTM)
SELECT 1, '222', 'SOME DESC',CURRENT_TIMESTAMP;
H98:Begin
set varSQLState = SQLSTATE;
set varErrorMessage= 'This message is displayed, ITEM_NUM invalid characters';
end H98;
-- NOW I AM DOING A SECOND INSERT TO table b WITH INVALID DATA
-- THE VALUE FOR THE ITEM NUMBER CONTAINS ALPHANUMERICE CHARACTERS
INSERT INTO "Table_b"
(ID , ITEM_NUM, DESC, CREATE_DTTM)
SELECT 1, '333F', 'SOME DESC',CURRENT_TIMESTAMP;
END ins6;
EndTrans: BEGIN
IF varSQLState <> '0' THEN
SET varRollbackNeededInd = 'Y';
SET varReturnCode = '9999';
END IF;
IF varRollbackNeededInd = 'Y' THEN
ROLLBACK; -- ROLLBACK AND SEND ERROR TO CALLER
SIGNAL SQLSTATE 'U0123' SET MESSAGE_TEXT = 'SQlState is - ' || varSQLSTATE || ' - and error is - ' || varErrorMessage;
ELSE
END TRANSACTION; -- COMMIT TRANSACTION
END IF;
END EndTrans;
END;
The problem that I am facing with the above stored procedure is that error message that I get is not the one that I am expecting. Since error is intentionally created in my second statement I am expecting to get: This message is displayed, ITEM_NUM invalid characters but I am getting This message should not be displayed
Now if I modify the PROCEDURE to have multiple handlers, one for each statement, I do get the correct error message, but now since I am intentionally generating the error in the first statement it does not terminate the procedure, it handles the error and sets the proper message but continues to process the next statement which I am not expecting to do this, so how can I terminate this procedure?
REPLACE PROCEDURE csTest2()
SQL SECURITY OWNER
BEGIN
DECLARE varErrorMessage char(256);
DECLARE varSQLState char(5);
DECLARE varReturnCode char(5);
DECLARE varRollbackNeededInd char(1); /* transaction mgt */
SET varRollbackNeededInd = 'N';
SET varReturnCode = '00000';
SET varErrorMessage = '';
BEGIN TRANSACTION;
ins6: BEGIN
DECLARE EXIT HANDLER FOR SQLEXCEPTION
H99:Begin
set varSQLState = SQLSTATE;
set varErrorMessage= 'Error is displayed in this case because ITEM_NUM';
-- ERROR IS PRESENT IN THIS STATEMENT AND SHOULD TERMINATE THE PROCEDURE.
INSERT INTO "Table_A"
(ID , ITEM_NUM, DESC, CREATE_DTTM)
SELECT 1, '222F', 'SOME DESC',CURRENT_TIMESTAMP;
END ins6;
ins7: BEGIN
H98:Begin
set varSQLState = SQLSTATE;
set varErrorMessage= 'no error is displayed in this case';
end H98;
-- NO ERROR IS EXPECTED, BUT IT SHOULD NOT REACH HERE SINCE WE HAD ERROR ON FIRST STATEMENT.
INSERT INTO "Table_b"
(ID , ITEM_NUM, DESC, CREATE_DTTM)
SELECT 1, '333', 'SOME DESC',CURRENT_TIMESTAMP;
END ins7;
EndTrans: BEGIN
IF varSQLState <> '0' THEN
SET varRollbackNeededInd = 'Y';
SET varReturnCode = '9999';
END IF;
IF varRollbackNeededInd = 'Y' THEN
ROLLBACK; -- ROLLBACK AND SEND ERROR TO CALLER
SIGNAL SQLSTATE 'U0123' SET MESSAGE_TEXT = 'SQlState is - ' || varSQLSTATE || ' - and error is - ' || varErrorMessage;
ELSE
END TRANSACTION; -- COMMIT TRANSACTION
END IF;
END EndTrans;
END;
I'm new to Eiffel and I'm trying to use the LINKED_LIST class for organizing instances of other class "MONOMIO" I've made. I added a function for ordering this elements and I use the remove and the cursor movement features and when I try to execute the code it raises an exception saying that the objects contained should be readable and writable. I would like to know how to do it, this is my class:
class
MONOMIO
feature --Initialization
make (coef:INTEGER; expX:INTEGER; expY:INTEGER)
do
coeficiente := coef
exponenteX := expX
exponenteY := expY
end
feature
evaluar(valX: INTEGER; valY: INTEGER): REAL_64
do
Result := coeficiente*(valX^exponenteX)*(valY^exponenteY)
end;
coeficiente: INTEGER;
exponenteX: INTEGER;
exponenteY: INTEGER;
feature --setter
set_coeficiente(val: INTEGER)
do
coeficiente := val
end;
end
I think the exception raises because of this feature I've made for a class that has as a feature the LINKED_LIST[MONOMIO] and it's called "contenido":
simplificar
local
tamanio_polinomio: INTEGER -- Número de monomios que tiene el polinomio
contador: INTEGER
monomio_a_comparar: MONOMIO -- Auxiliar
coeficiente_total:INTEGER -- Auxiliar
indice_monomio_en_revision:INTEGER
do
from
contenido.start
indice_monomio_en_revision := 0
tamanio_polinomio := contenido.count
until
indice_monomio_en_revision = tamanio_polinomio
loop
contenido.start
contenido.move (indice_monomio_en_revision)
monomio_a_comparar := contenido.item
from
contador := indice_monomio_en_revision
coeficiente_total := monomio_a_comparar.coeficiente
contenido.forth
until
contador = tamanio_polinomio
loop
if
(monomio_a_comparar.exponentex = contenido.item.exponentex) and
(monomio_a_comparar.exponentey = contenido.item.exponentey)
then
coeficiente_total := coeficiente_total + contenido.item.coeficiente
contenido.remove -- Mueve el cursor a la derecha
tamanio_polinomio := tamanio_polinomio - 1
contador := contador - 1
else
if
not contenido.islast
then
contenido.forth
end
end
contador := contador + 1
end
contenido.start
contenido.move (indice_monomio_en_revision)
contenido.item.set_coeficiente (coeficiente_total)
indice_monomio_en_revision := indice_monomio_en_revision + 1
end
end;
I hope anyone can help me with this problem. Thanks.
Suppose you have a list with 1 element. Then we enter the outer loop and move to the first element. Then we execute contador := indice_monomio_en_revision that is still 0 at this point and do contenido.forth. Now we are beyond the list because there is only one element. However contador = tamanio_polinomio is false (0 = 1), so we enter the inner loop and try to retrieve the second (non-existing) item. BOOM!
Other issues include:
There are multiple calls like contenido.start followed by contenido.move. You could use a single call to go_i_th instead.
Instead of counting number of items in the list I would look at the feature after. It tells when you reach an end of the list. It would simplify the logic of your loop (e.g. the call to islast would be removed) and let you to remove some local variables.
Taking the last point into account I would write the inner loop condition as
contenido.after
At least this would avoid the crash you experience. As to the logic, you may need to check features start, after, forth and remove to see what effect they have. The usual way to write loops in such cases is like
from
l.start
until
l.after
loop
... -- Use l.item
l.forth
end
In case of remove probably you do not need to call forth.
I am attempting to write two functions that add and remove a folder from a IShellLibrary. I started with this, but the function produces an exception in System._IntfClear:
First chance exception at $000007FEFE 168BC4. Exception class $C0000005 with Message 'c0000005 ACCESS_VIOLATION'.
The SHAddFolderPathToLibrary is the line that causes the exception.
I guess I need to add the library name to the function?
function AddFolderToLibrary(AFolder: string): HRESULT;
{ Add AFolder to Windows 7 library. }
var
plib: IShellLibrary;
begin
Result := CoCreateInstance(CLSID_ShellLibrary, nil, CLSCTX_INPROC_SERVER,
IID_IShellLibrary, plib);
if SUCCEEDED(Result) then
begin
Result := SHAddFolderPathToLibrary(plib, PWideChar(AFolder));
end;
end;
function RemoveFolderFromLibrary(AFolder: string): HRESULT;
{ Remove AFolder from Windows 7 library. }
var
plib: IShellLibrary;
begin
Result := CoCreateInstance(CLSID_ShellLibrary, nil, CLSCTX_INPROC_SERVER,
IID_IShellLibrary, plib);
if SUCCEEDED(Result) then
begin
Result := SHRemoveFolderPathFromLibrary(plib, PWideChar(AFolder));
end;
end;
The problem here is that the Embarcadero engineer who translated SHAddFolderPathToLibrary does not understand COM reference counting, and how it is handled by different compilers.
Here's how SHAddFolderPathToLibrary is implemented in the C++ header file Shobjidl.h. It's actually an inline wrapper of other core API calls:
__inline HRESULT SHAddFolderPathToLibrary(_In_ IShellLibrary *plib,
_In_ PCWSTR pszFolderPath)
{
IShellItem *psiFolder;
HRESULT hr = SHCreateItemFromParsingName(pszFolderPath, NULL,
IID_PPV_ARGS(&psiFolder));
if (SUCCEEDED(hr))
{
hr = plib->AddFolder(psiFolder);
psiFolder->Release();
}
return hr;
}
And the Delphi translation is very faithful, indeed too faithful:
function SHAddFolderPathToLibrary(const plib: IShellLibrary;
pszFolderPath: LPCWSTR): HResult;
var
psiFolder: IShellItem;
begin
Result := SHCreateItemFromParsingName(pszFolderPath, nil, IID_IShellItem,
psiFolder);
if Succeeded(Result) then
begin
Result := plib.AddFolder(psiFolder);
psiFolder._Release();
end;
end;
The problem is the call to _Release. The Delphi compiler manages reference counting, and so this explicit call to _Release is bogus and should not be there. Since the compiler will arrange for a call to _Release, this extra one simply unbalances the reference counting. The reason why _AddRef and _Release are prefixed with _ is to remind people not to call them and to let the compiler do that.
The call to Release in the C++ version is accurate because C++ compilers don't automatically call Release for you unless you wrap the interface in a COM smart pointer. But the Embarcadero engineer has blindly copied it across and you are left with the consequences. Clearly this code has never even been executed by the Embarcadero engineers.
You'll need to supply your own corrected implementation of this function. And also any other erroneously translated function. Search for _Release in the ShlObj unit, and remove them in your corrected versions. There are other bugs in the translation, so watch out. For example, SHLoadLibraryFromItem (and others) declare local variable plib: ^IShellLibrary which should be plib: IShellLibrary.
I submitted a QC report: QC#117351.
I have invented my own algorithm that I propose here, non-recursive, which takes up very little memory and removes folders of any depth and file (s) with special attributes. Unfortunately the comments are still in Italian.
To explain how it works: you have to initialize the deletion of the file or folder with the procedure InitDelT (Dir: String; Var DelTRec: TDelTRec); and run several times, for example in a sort of loop, the function DelT (Var DelTRec: TDelTRec): Byte;, which returns:
2 -> Deletion completed successfully.
3 -> Deletion failed.
The DelTRec variable: TDelTRec contains:
PathName, BaseDir, Msg: String;
Status: Byte;
{Status: 0 -> Deleting (no items deleted yet).
1 -> Deleting (1 item just deleted).
2 -> Deletion completed successfully.
3 -> Deletion failed}.
Unit DelTU;
Interface
Type TDelTRec=Record
PathName,BaseDir,Msg:String;
Status:Byte;
{Status: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
1 -> Eliminazione in corso (1 elemento appena eliminato).
2 -> Eliminazione terminata con successo.
3 -> Eliminazione fallita}
End;
Function KeepExtendedDir (Dir:String):String;
{Preleva la Dir non normalizzata
(con BACKSLASH) da Dir.
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function KeepNormDir (Dir:String):String;
{Preleva la Dir normalizzata
(senza BACKSLASH) da Dir.
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function GetPathNameDir (PathName:String):String;
{Ritorna l' UNITà ed il PERCORSO DI PathName}
Procedure FileSplit (FileName:String;
Var Drive,Dir,Name,Ext:String);
{Scompone un PERCORSO DI FILE FileName
IN UNITà (DRIVE), Dir (Dir), nome (Name)
ed estensione (Ext).
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Procedure FSplit (FileName:String;
Var Dir,Name,Ext:String);
{Scompone un PERCORSO DI FILE FileName
Path (Dir), nome (Name)
ed estensione (Ext).
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function Is_Drive_Or_Root (Dir:String):Boolean;
{Verifica Se la Dir specificata da Dir è
una ROOT Dir o un DRIVE (IN questo caso ritorna TRUE).
Ritorna FALSE Se Dir è una Sub-DIRECTORY}
Function File_Exists_Sub (FileName:String;Attr:Integer;
Var Attr_Read:Integer):Boolean;
{Verifica che un FILE o una Dir FileName esista
ed abbia attributi compresi IN Attr.
Se FileName ha uno o più attributi che differiscono da Attr, ritorna FALSE.
Se FileName non ha attributi, ritorna TRUE.
Ritorna FALSE solo IN caso DI ERRORE,
altrimenti Attr_Read contiene gli attributi DI FileName.
NOTE: Per trovare qualsiasi FILE:
Attr= faAnyFile-
faVolumeId-
faDirectory.
Per trovare qualsiasi FILE E DIRECTORY:
Attr= faAnyFile-
faVolumeId.
Per trovare qualsiasi DIRECTORY:
Found:=File_Exists_Sub(FileName,faAnyFile-faVolumeId,Attr_Read) AND
((Attr_Read AND faDirectory)<>0)}
Function File_Exists (FileName:String):Boolean;
(* Controlla che FileName sia un FILE esistente *)
Function Dir_Exists (FileName:String):Boolean;
(* Controlla che FileName sia una DIRECTORY esistente *)
Function FDel (Source:String):Boolean;
(* Rimuove qualsiasi file, anche con attributi speciali;
non imposta ErrorMsg *)
Function RmDir (Source:String):Boolean;
(* Rimuove qualsiasi directory vuota, anche con attributi speciali;
non imposta ErrorMsg *)
Procedure InitDelT (Dir:String;
Var DelTRec:TDelTRec);
{Inizializzazione funzione "remove not empty folder" alias DelT().
Dir è il percorso assoluto della cartella da rimuovere;
può essere specificato anche senza il backslash finale.
Nel caso Dir non esista, questa funzione disabilita la rimozione;
altrimenti essa potrà avvenire in background, chiamando DelT()}
Function DelT (Var DelTRec:TDelTRec):Byte;
{Funzione "remove not empty folder" alias DelT().
La rimozione potrà avvenire in background, chiamando DelT() dopo
aver inizializzato DelTRec con InitDelT().
Ritorna: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
1 -> Eliminazione in corso (1 elemento appena eliminato).
2 -> Eliminazione terminata con successo.
3 -> Eliminazione fallita.
ALGORITMO:
---------:
- specificare full-path-name PathName con filtro *.*;
es.: c:\programs.pf\graphic.pf\*.*
- Copiare nella base-path BaseDir il percorso della cartella da rimuovere;
es.: c:\programs.pf
- RemoveDir <- False.
- Preleva FileName1 e Dir da PathName.
- Se FileName1="<Rm_Dir>":
- RemoveDir <- True.
- Preleva FileName1 e Dir da Dir (normalizzata).
- NoSuchFile1 <- False
- Cerca la prima ricorrenza di FileName1 in Dir.:
- Imposta NoSuchFile1 <- True, se non esiste.
- NoSuchFile2 <- True
- SetFileName2 <- False
- Se NoSuchFile1 = False:
- Cerca il file o dir. successivo FileName2 in Dir:
- Imposta NoSuchFile2 <- True, se non esiste.
- Se RemoveDir=True:
- Rimuove la dir. FileName1
- Se Dir=BaseDir, ha finito.
- SetFileName2 <- True
- Se RemoveDir=False:
- Se FileName1 è un file:
- Rimuove il file FileName1.
- SetFileName2 <- True
- Se FileName1 è una dir.:
- Imposta PathName con Dir., FileName1 e *.*
- Se (NoSuchFile2 = False) E SetFileName2:
- Se FileName2 è un file, imposta PathName con Dir. e FileName2
- Se FileName2 è una dir., imposta PathName con Dir., FileName2 e *.*
- Se (NoSuchFile2 = True) E SetFileName2 O
(NoSuchFile1 = True):
- Imposta PathName con Dir. e "<Rm_Dir>"}
{-----------------------------------------------------------------------}
Implementation
Uses SysUtils;
Function KeepExtendedDir(Dir:String):String;
Var Len:Integer;
Begin
Len:=Length(Dir);
If (Len>0) And Not (Dir[Len] In [':','\']) Then
KeepExtendedDir:=Dir+'\'
Else
KeepExtendedDir:=Dir;
End;
Function KeepNormDir(Dir:String):String;
Var Len:Integer;
Begin
Len:=Length(Dir);
If (Len>1) And
(Dir[Len]='\') And
(Dir[Len-1]<>':') Then
KeepNormDir:=Copy(Dir,1,Len-1)
Else
KeepNormDir:=Dir;
End;
Function GetPathNameDir(PathName:String):String;
Var Index:Integer;
Begin
Index:=Length(PathName);
While (Index>0) And Not (PathName[Index] In ['\',':']) Do
Dec(Index);
GetPathNameDir:=Copy(PathName,1,Index);
End;
Procedure FileSplit(FileName:String;
Var Drive,Dir,Name,Ext:String);
Var Ch:Char;
Index,Flag:Integer;
Begin
Drive:='';
Dir:='';
Name:='';
Ext:='';
Flag:=0;
Index:=Length(FileName);
While Index>0 Do
Begin
Ch:=FileName[Index];
Case Ch Of
'\':If Flag<3 Then
Flag:=2;
':':Flag:=3;
'.':If Flag=0 Then
Flag:=1;
End;
Case Flag Of
0:Name:=Ch+Name;
1:If Ext='' Then
Begin
Ext:=Ch+Name;
Name:='';
End
Else
Name:=Ch+Name;
2:Dir:=Ch+Dir;
3:Drive:=Ch+Drive;
End;
Dec(Index);
End;
End;
Procedure FSplit(FileName:String;
Var Dir,Name,Ext:String);
Var Drive:String;
Begin
FileSplit(FileName,Drive,Dir,Name,Ext);
Dir:=Drive+Dir;
End;
Function Is_Drive_Or_Root(Dir:String):Boolean;
Const Special_Chars:Array[Boolean] Of Char=(':','\');
Var Len:Integer;
Begin
Len:=Length(Dir);
Is_Drive_Or_Root:=((Len=1) Or (Len=2) Or (Len=3) And (Dir[2]=':')) And
(Dir[Len]=Special_Chars[Odd(Len)]);
End;
Function File_Exists_Sub(FileName:String;Attr:Integer;
Var Attr_Read:Integer):Boolean;
(* per trovare qualsiasi FILE:
Attr= faAnyFile-
faVolumeId-
faDirectory *)
Var TempOut:Boolean;
SR:TSearchRec;
Begin
Attr_Read:=0;
TempOut:=((Attr And faDirectory)<>0) And
Is_Drive_Or_Root(FileName);
If Not TempOut And
(FindFirst(FileName,Attr,SR)=0) Then
Begin
TempOut:=True;
Attr_Read:=SR.Attr;
FindClose(SR);
End;
File_Exists_Sub:=TempOut;
End;
Function File_Exists(FileName:String):Boolean;
Var Attr_Read:Integer;
Begin
File_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
SysUtils.faVolumeId-
SysUtils.faDirectory,
Attr_Read);
End;
Function Dir_Exists(FileName:String):Boolean;
Var Attr_Read:Integer;
Begin
Dir_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
SysUtils.faVolumeId,
Attr_Read) And
((Attr_Read And faDirectory)<>0);
End;
Function FDel(Source:String):Boolean;
Var Attr:Integer;
Begin
FDel:=False;
Source:=KeepNormDir(Source);
Attr:=SysUtils.FileGetAttr(Source);
If (Attr And SysUtils.faDirectory)=0 Then
Begin
If (Attr And (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile))<>0 Then
SysUtils.FileSetAttr(Source,
Attr And Not (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile));
FDel:=DeleteFile(Source);
End;
End;
Function RmDir(Source:String):Boolean;
Var Attr:Integer;
Begin
RmDir:=False;
Source:=KeepNormDir(Source);
Attr:=SysUtils.FileGetAttr(Source);
If (Attr And SysUtils.faDirectory)<>0 Then
Begin
If (Attr And (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile))<>0 Then
SysUtils.FileSetAttr(Source,
Attr And Not (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile));
RmDir:=RemoveDir(Source);
End;
End;
Procedure InitDelT(Dir:String;
Var DelTRec:TDelTRec);
Begin
With DelTRec Do
Begin
PathName:=KeepExtendedDir(Dir)+'*.*';
Dir:=KeepNormDir(Dir);
Status:=3 And -Byte(Not Dir_Exists(Dir));
BaseDir:=GetPathNameDir(Dir);
Msg:='';
End;
End;
Function DelT(Var DelTRec:TDelTRec):Byte;
Var RemoveDir,SuchFile1,SuchFile2,SetFileName2,FF:Boolean;
Dir,Name,Ext:String;
SR1,SR2:TSearchRec;
Begin
With DelTRec Do
Begin
If Status<2 Then
Begin
Status:=0;
RemoveDir:=False;
FSplit(PathName,Dir,Name,Ext);
If Name+Ext='<Rm_Dir>' Then
Begin
RemoveDir:=True;
FSplit(KeepNormDir(Dir),Dir,Name,Ext);
End;
FF:=FindFirst(Dir+'*.*',
SysUtils.faAnyFile-
SysUtils.faVolumeId,SR2)=0;
SuchFile1:=FF;
While SuchFile1 And
((SR2.Name='.') Or (SR2.Name='..')) Do
SuchFile1:=FindNext(SR2)=0;
SuchFile2:=False;
SetFileName2:=False;
If SuchFile1 Then
Begin
SR1:=SR2;
SuchFile2:=FindNext(SR2)=0;
If RemoveDir Then
Begin
Msg:=Dir+Name+Ext;
If Not RmDir(Msg) Then
Status:=3
Else
If Dir=BaseDir Then
Status:=2
Else
Status:=1;
SetFileName2:=True;
End
Else
If (SR1.Attr And SysUtils.faDirectory)=0 Then
Begin
Msg:=Dir+SR1.Name;
If FDel(Msg) Then
Status:=1
Else
Status:=3;
SetFileName2:=True;
End
Else
PathName:=Dir+SR1.Name+'\*.*';
End;
If SuchFile2 And SetFileName2 Then
If (SR2.Attr And SysUtils.faDirectory)=0 Then
PathName:=Dir+SR2.Name
Else
PathName:=Dir+SR2.Name+'\*.*';
If Not SuchFile2 And SetFileName2 Or Not SuchFile1 Then
PathName:=Dir+'<Rm_Dir>';
If FF Then
FindClose(SR2);
End;
DelT:=Status;
End;
End;
End.
This is an example (DelTUT.DPR):
program DelTUT;
{$APPTYPE CONSOLE}
uses SysUtils,
DelTU in 'DelTU.pas';
Var DelTRec:TDelTRec;
Dir:String;
begin
{ TODO -oUser -cConsole Main : Insert code here }
WriteLn('Insert the full path-name of the folder to remove it:');
ReadLn(Dir);
WriteLn('Press ENTER to proceed ...');
InitDelT(Dir,DelTRec);
WriteLn('Removing...');
While Not (DelT(DelTRec) In [2,3]) Do
Write(#13,DelTRec.Msg,#32);
WriteLn;
If DelTRec.Status=3 Then
WriteLn('Error!')
Else
WriteLn('Ok.')
end.