Monotone chain change data structure to doubly linked list - computational-geometry

for (size_t i = 0; i < n; ++i) {
while (k >= 2 && cross(H[k-2], H[k-1], P[i]) <= 0) k--;
H[k++] = P[i];
for (size_t i = n-1, t = k+1; i > 0; --i) {
while (k >= t && cross(H[k-2], H[k-1], P[i-1]) <= 0) k--;
H[k++] = P[i-1];
I found the code for it on wikipedia but for some reasons I prefer to use doubly linked list as data structure The problem is in this first condition for while loop while(k>=2&&...) and while(k>=t && ...)
How can I rewrite these while loops on linked list

unit DoublyLinkedList;
interface
const NULL = NIL;
type TPoint = record
x,y:longint;
end;
PLink = ^TLink;
TLink = record
point:TPoint;
next:PLink;
prev:PLink;
end;
TList = record
first:PLink;
last:PLink;
end;
TFunc = function(A,B:TPoint):integer;
procedure ListInit(var L:TList);
function ListFind(L:TList;key:TPoint):PLink;
function ListIsEmpty(L:TList):boolean;
procedure ListInsertFirst(var L:TList;dd:TPoint);
procedure ListInsertLast(var L:TList;dd:TPoint);
procedure ListDeleteFirst(var L:TList);
procedure ListDeleteLast(var L:TList);
procedure ListInsert(var L:TList;dd:TPoint);
function ListInsertAfter(var L:TList;key,dd:TPoint):boolean;
procedure ListDeleteKey(var L:TList;key:TPoint);
procedure ListDisplayForward(L:TList);
procedure ListDisplayBackward(L:TList);
procedure BSTsort(var L:TList);
implementation
function equals(p1,p2:TPoint):boolean;
begin
equals:=(p1.x = p2.x) and (p1.y = p2.y);
end;
function compare(A,B:TPoint):integer;
var t:integer;
begin
t := 1;
if(A.x < B.x)or((A.x = B.x)and(A.y < B.y))then
t := -1;
if(A.x = B.x)and(A.y = B.y)then
t := 0;
compare := t;
end;
procedure BSTinsert(var root:PLink;x:PLink);
begin
if root = NULL then
begin
root := x;
x^.prev := NULL;
x^.next := NULL;
end
else if compare(root^.point,x^.point) = 0 then
BSTinsert(root^.prev,x)
else if compare(root^.point,x^.point) < 0 then
BSTinsert(root^.next,x)
else
BSTinsert(root^.prev,x);
end;
procedure BSTtoDLL(root:PLink;var L:TList);
begin
if root <> NULL then
begin
BSTtoDLL(root^.prev,L);
if ListIsEmpty(L) then
L.first := root
else
L.last^.next := root;
root^.prev := L.last;
L.last := root;
BSTtoDLL(root^.next,L);
end;
end;
procedure BSTsort(var L:TList);
var root,temp:PLink;
begin
root := NULL; (*This instruction was missing in the code *)
while not ListIsEmpty(L)do
begin
temp := L.first;
if L.first^.next = NULL then
L.last := NULL
else
L.first^.next^.prev := NULL;
L.first := L.first^.next;
BSTinsert(root,temp);
end;
BSTtoDLL(root,L);
end;
procedure ListInit(var L:TList);
begin
L.first := NULL;
L.last := NULL;
end;
function ListFind(L:TList;key:TPoint):PLink;
var p:PLink;
begin
p := L.first;
while(p <> NULL)and(not equals(key,p^.point))do
p := p^.next;
ListFind := p;
end;
function ListIsEmpty(L:TList):boolean;
begin
ListIsEmpty := L.first = NULL;
end;
procedure ListInsertFirst(var L:TList;dd:TPoint);
var newLink:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if ListIsEmpty(L) then
L.last := newLink
else
L.first^.prev := newLink;
newLink^.next := L.first;
L.first := newLink;
end;
procedure ListInsertLast(var L:TList;dd:TPoint);
var newLink:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if ListIsEmpty(L) then
L.first := newLink
else
begin
L.last^.next := newLink;
newLink^.prev := L.last;
end;
L.last := newLink;
end;
procedure ListDeleteFirst(var L:TList);
var temp:PLink;
begin
if not ListIsEmpty(L) then
begin
temp := L.first;
if L.first^.next = NULL then
L.last := NULL
else
L.first^.next^.prev := NULL;
L.first := L.first^.next;
dispose(temp);
end;
end;
procedure ListDeleteLast(var L:TList);
var temp:PLink;
begin
if not ListIsEmpty(L) then
begin
temp := L.last;
if L.first^.next = NULL then
L.first := NULL
else
L.last^.prev^.next := NULL;
L.last := L.last^.prev;
dispose(temp);
end;
end;
procedure ListInsert(var L:TList;dd:TPoint);
var newLink,current:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
current := L.first;
while(current <> NULL)and(compare(newLink^.point,current^.point) > 0)do
current := current^.next;
if current = NULL then
begin
if ListIsEmpty(L)then
L.first := newLink
else
begin
L.last^.next := newLink;
newLink^.prev := L.last;
end;
L.last := newLink;
end
else if current^.prev = NULL then
begin
L.first := newLink;
newLink^.next := current;
current^.prev := newLink;
newLink^.prev := NULL;
current := newLink;
end
else
begin
current^.prev^.next := newLink;
newLink^.next := current;
newLink^.prev := current^.prev;
current^.prev := newLink;
end;
end;
function ListInsertAfter(var L:TList;key,dd:TPoint):boolean;
var newLink,current:PLink;
found:boolean;
begin
current := ListFind(L,key);
found := current <> NULL;
if found then
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if current^.next = NULL then
begin
newLink^.next := NULL;
L.last := newLink;
end
else
begin
newLink^.next := current^.next;
current^.next^.prev := newLink;
end;
newLink^.prev := current;
current^.next := newLink;
end;
ListInsertAfter:= found;
end;
procedure ListDeleteKey(var L:TList;key:TPoint);
var current:PLink;
begin
current := ListFind(L,key);
if current <> NULL then
begin
if current^.prev = NULL then
L.first := current^.next
else
current^.prev^.next := current^.next;
if current^.next = NULL then
L.last := current^.prev
else
current^.next^.prev := current^.prev;
dispose(current);
end;
end;
procedure ListDisplayForward(L:TList);
var current :PLink;
begin
write('List (first-->last): ');
current := L.first;
while current <> NIL do
begin
write('(',current^.point.x,',',current^.point.y,') -> ');
current := current^.next;
end;
writeln('NULL');
end;
procedure ListDisplayBackward(L:TList);
var current :PLink;
begin
write('List (last-->first): ');
current := L.last;
while current <> NIL do
begin
write('(',current^.point.x,',',current^.point.y,') -> ');
current := current^.prev;
end;
writeln('NULL');
end;
begin
end.
program MonotoneChain;
uses crt,doublylinkedlist;
function equals(a,b:TPoint):boolean;
begin
equals := (a.x = b.x) and (a.y = b.y)
end;
function vect(a1,a2,b1,b2:TPoint):longint;
begin
vect := (a2.x - a1.x) * (b2.y - b1.y) - (b2.x - b1.x) * (a2.y - a1.y)
end;
function dist2(a1,a2:TPoint):longint;
begin
dist2 := sqr(a2.x - a1.x) + sqr(a2.y-a1.y)
end;
procedure Solve(var A,B:TList);
var k,t:longint;
pt:PLink;
begin
ListInit(B);
if not ListIsEmpty(A)then
begin
k := 0;
pt := A.first;
while pt <> NULL do
begin
while(k >= 2)and(vect(B.last^.prev^.point,B.last^.point,B.last^.prev^.point,pt^.point) <= 0)do
begin
ListDeleteLast(B);
k := k - 1;
end;
ListInsertLast(B,pt^.point);
k := k + 1;
pt := pt^.next;
end;
t := k + 1;
pt := A.last;
while pt <> NULL do
begin
while(k >= t)and(vect(B.last^.prev^.point,B.last^.point,B.last^.prev^.point,pt^.point) <= 0)do
begin
ListDeleteLast(B);
k := k - 1;
end;
ListInsertLast(B,pt^.point);
k := k + 1;
pt := pt^.prev;
end;
ListDeleteLast(B);
end;
end;
procedure main;
var A,B:TList;
input:text;
p:TPoint;
path:string;
begin
ListInit(A);
writeln('Podaj sciezke do pliku z danymi do wczytania');
readln(path);
path := 'F:\fpc\3.0.4\bin\i386-win32\monotonechain\' + path;
assign(input,path);
{$I-}
reset(input);
{$I+}
if IOResult <> 0 then
writeln('Pliku nie udalo sie wczytac')
else
begin
while not eof(input) do
begin
while not eoln(input) do
begin
read(input,p.x,p.y);
ListInsertLast(A,p);
end;
readln(input);
writeln('List A');
ListDisplayForward(A);
ListDisplayBackward(A);
BSTsort(A);
Solve(A,B);
writeln('List A');
ListDisplayForward(A);
ListDisplayBackward(A);
writeln('List B');
ListDisplayForward(B);
ListDisplayBackward(B);
while not ListIsEmpty(A) do
ListDeleteFirst(A);
while not ListIsEmpty(B) do
ListDeleteFirst(B);
end;
close(input);
end;
readkey;
end;
BEGIN
main;
END.
Here is the code
Segmentation fault appears while I try to sort
the list using BST
Probably when I try to insert the node removed from head of the list to the BST
Segmentation fault appears only when I call it from procedure which finds the convex hull
When I call it from main block of code everything seem to be ok
One of the casese of segmentetion fault is dereferencing null pointer
but i dont know is this segmentation fault caused by dereferencing null pointer
It is strange for me that BSTsort called in main block of code works ok
but BSTsort called in Solve procedure causes segmentation fault
I think i know how to correct this sorting procedure
but I would like to know why segmentation fault occured and why only
in Solve procedure

Related

oracle sequence match & exact word match for a column

currently matching with UTL_MATCH.jaro_winkler_similarity (upper(colname),upper(variablename)) jws.
how to achieve sequence match & exact word match?
That's exact match, then. Is it not? Then you just have to compare colname to variablename, directly, e.g.
if colname = variablename then
-- that's exact match, do something
create or replace FUNCTION NUMOFSEQWORDS
(
P_STR1 IN VARCHAR2
, P_STR2 IN VARCHAR2
) RETURN NUMBER AS
l_str1 varchar2(4000) := p_str1;
l_str2 varchar2(4000) := p_str2;
l_res number default 0;
l_del_pos1 number;
l_del_pos2 number;
l_word1 varchar2(1000);
l_word2 varchar2(1000);
l_word_cnt number;
l_word_cnt1 number;
l_word_cnt2 number;
l_word_weight number:=0;
l_jws number:=0;
BEGIN
select regexp_count(l_str1, '[^ ]+') into l_word_cnt1 from dual;
select regexp_count(l_str2, '[^ ]+') into l_word_cnt2 from dual;
l_word_cnt:=LEAST(l_word_cnt1,l_word_cnt2);
--l_word_cnt:=greatest(l_word_cnt1,l_word_cnt2);
l_word_weight:=100.0/l_word_cnt;
begin
loop
l_del_pos1 := instr(l_str1, ' ');
l_del_pos2 := instr(l_str2, ' ');
case l_del_pos1
when 0
then l_word1 := l_str1;
l_str1 := '';
else l_word1 := substr(l_str1, 1, l_del_pos1 - 1);
end case;
case l_del_pos2
when 0
then l_word2 := l_str2;
l_str2 := '';
else l_word2 := substr(l_str2, 1, l_del_pos2 - 1);
end case;
exit when (l_word1 <> l_word2) or
((l_word1 is null) or (l_word2 is null));
if (l_word1 = l_word2) then
l_res := l_res + 1;
end if;
l_str1 := substr(l_str1, l_del_pos1 + 1);
l_str2 := substr(l_str2, l_del_pos2 + 1);
end loop;
--return l_res;
return l_res*l_word_weight;
end;
END NUMOFSEQWORDS;
I ended up creating function above to find the match weightage between two strings
We can use LEAST or greatest to find weightage

search in multilevel linked lists in Pascal

So in this program we are asked to create a database for a university, the university is divided into faculties and each faculty is divided into departments, similarly, each department is divided into courses (specialities) and each course is divided into grades, and each grade has a list of students. I implemented this using linked lists, after the user fills the database, they get some options to interact with the database such as adding and removing students, etc. But, when I try to search for a student in the database it seems not to search well although the method works well when searching for a course (it gives in which faculty the course is and in which department). When the program is executed it gives us the message ("name" doesn't exist in this database) which indicates that cmp is still set to 0.
Program Liked_lists_database;
Type
Node = ^T;
T = record
age : string;
next, link : Node;
end;
Var
Head, Tail, Last, tmp, tmp2, tmp3, tmp4, tmp5 : Node;
y : string;
cmp : integer;
Begin
writeln('[+] Create your database [+]');
writeln;
Repeat
write('Enter the name of the faculty : ');
readln(j);
if (j='exit') then break;
if (Head = nil) then
Begin
new(Head);
Tail := Head;
End
Else
Begin
new(Tail^.next);
Tail := Tail^.next;
End;
Tail^.age := j;
Tail^.next := nil;
Repeat
Write('Enter the name of the department : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link=Nil) Then
Begin
new(Tail^.link);
Last := Tail^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the name of the course : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link=Nil) Then
Begin
new(Tail^.link^.link);
Last := Tail^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the grade : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link^.link=Nil) Then
Begin
new(Tail^.link^.link^.link);
Last := Tail^.link^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the name of the student : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link^.link^.link=Nil) Then
Begin
new(Tail^.link^.link^.link^.link);
Last := Tail^.link^.link^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Until false;
Until false;
Until false;
Until false;
Until false;
writeln;
writeln('...The database has been created successfully!');
// Search for a student
writeln('[+] Search for a student');
write('Enter the name of the student to Search for : ');
readln(y);
tmp := Head;
cmp := 0;
if (cmp=0) then
While (tmp^.next<>Nil) Do
Begin
tmp2 := tmp^.link;
While (tmp2^.next<>Nil) Do
Begin
tmp3 := tmp2^.link;
While (tmp3^.next<>Nil) Do
Begin
tmp4 := tmp3^.link;
While (tmp4^.next<>Nil) Do
Begin
tmp5 := tmp4^.link;
While (tmp5^.next<>Nil) Do
Begin
if (tmp5^.age=y) then
cmp := cmp + 1;
tmp5 := tmp5^.next;
End;
if (cmp>0) then
tmp4^.next := Nil
Else
tmp4 := tmp4^.next;
End;
if (cmp>0) then
tmp3^.next := Nil
Else
tmp3 := tmp3^.next;
End;
if (cmp>0) then
tmp2^.next := Nil
Else
tmp2 := tmp2^.next;
End;
if (cmp>0) then
tmp^.next := Nil
Else
tmp := tmp^.next;
End;
if (cmp>0) then
Begin
writeln('Name : ',y);
writeln('Faculty : ', tmp^.age);
writeln('Department : ', tmp2^.age);
writeln('Speciality : ', tmp3^.age);
writeln('Grade : ', tmp4^.age);
End
Else
writeln(y, ' does not exist in this database');
End.
EDIT : the problem was with the implementation of the multilevel linked list and the searching algorithm
Program Liked_lists_database;
Type
Node = ^T;
T = record
age : string;
next, link : Node;
end;
Var
Head, Tail, tmp, Last : Node;
j: string;
num : integer;
Procedure searchCourse;
Var
cmp : integer;
y : string;
tmp, tmp2, tmp3 : Node;
Begin
writeln('[+] Search for a course');
write('Enter the name of the course to Search for : ');
readln(y);
tmp := Head;
cmp := 0;
if (tmp^.next=Nil) Then
new(tmp^.next);
While (tmp^.next<>Nil) Do
Begin
tmp2 := tmp^.link;
if (tmp2^.next=Nil) Then
new(tmp2^.next);
While (tmp2^.next<>Nil) Do
Begin
tmp3 := tmp2^.link;
While (tmp3<>Nil) Do
Begin
if (tmp3^.age=y) Then
Begin
writeln('[', y, '] is found in faculty of [ ', tmp^.age, ']', ' department of [', tmp2^.age, ']');
cmp := 1;
End;
tmp3 := tmp3^.next;
End;
if (cmp=0) Then
Begin
tmp2 := tmp2^.next;
if (tmp2^.next=Nil) Then
new(tmp2^.next);
End
Else
tmp2^.next := Nil;
End;
if (cmp=0) Then
Begin
tmp := tmp^.next;
if (tmp^.next=Nil) Then
new(tmp^.next);
End
Else
tmp^.next := Nil;
End;
if (cmp=0) Then
writeln ('[', y, '] : there is no such course');
End;
Begin
// Fillin in the database
writeln('[+] Create your database [+]');
writeln;
Repeat
write('Enter the name of the faculty : ');
readln(j);
if (j='exit') then break;
if (Head = nil) then
Begin
new(Head);
Tail := Head;
End
Else
Begin
new(Tail^.next);
Tail := Tail^.next;
End;
Tail^.age := j;
Tail^.next := nil;
Repeat
Write('Enter the name of the department : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link=Nil) Then
Begin
new(Tail^.link);
Last := Tail^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the name of the course : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link=Nil) Then
Begin
new(Tail^.link^.link);
Last := Tail^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the grade : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link^.link=Nil) Then
Begin
new(Tail^.link^.link^.link);
Last := Tail^.link^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Repeat
Write('Enter the name of the student : ');
Readln(j);
if (j='exit') then break;
if (Tail^.link^.link^.link^.link=Nil) Then
Begin
new(Tail^.link^.link^.link^.link);
Last := Tail^.link^.link^.link^.link;
End
Else
Begin
new(Last^.next);
Last := Last^.next;
End;
Last^.age := j;
Last^.next := Nil;
Until false;
Until false;
Until false;
Until false;
Until false;
writeln;
writeln('...The database has been created successfully!');
searchCourse;
Readln;
End.

TidTcpserver Verify commands List

I Am trying to protect my Tidtcpserver from unknown commands
This is how my Verify commands function looks like
function TConnection.Verfieycmds(const CMSTOV: String): BOOLEAN;
var
CMDSTOVERFIYE : Tstringlist;
I : integer;
CommandFound : Boolean;
begin
Result := False;
CommandFound := False;
if Commandlist <> nil then
begin
CMDSTOVERFIYE := Commandlist.Lock;
try
for I := 0 to CMDSTOVERFIYE.Count - 1 do
begin
if CMSTOV = CMDSTOVERFIYE[I] then
begin
CommandFound := True;
end;
end;
CommandFound := True;
Result := CommandFound;
finally
Commandlist.Unlock;
end;
end;
end;
after adding this check on execute event and after few clients connect the server application freezed and need to be restarted and the exception log were empty
here is my server code
type
TConnection = class(TIdServerContext)
private
{Private}
public
{Public}
OutboundCache: TIdThreadSafeStringList;
Commandlist: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
Name: String;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure TcpServerConnect(AContext: TIdContext);
procedure TcpServerDisconnect(AContext: TIdContext);
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCloseQuery(Sender: TObject; var CanClose: BOOLEAN);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure TcpServerListenException(AThread: TIdListenerThread;
AException: Exception);
private
{ Private declarations }
LastUniqueID: Dword;
procedure HandleExceptions(Sender: TObject; E: Exception);
procedure UpdateBindings;
public
{ Public declarations }
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
Commandlist := TIdThreadSafeStringList.Create;
Commandlist.Add('Command1');
Commandlist.Add('Command2');
Commandlist.Add('Command3');
Commandlist.Add('Command4');
Commandlist.Add('Command5');
Commandlist.Add('Command6');
Commandlist.Add('Command7');
Commandlist.Add('Command8');
Commandlist.Add('Command9');
Commandlist.Add('Command10');
Commandlist.Add('Command11');
Commandlist.Add('Command12');
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
Commadcaches : TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
if Commandlist <> nil then
begin
Commadcaches := Commandlist.Lock;
try
for I := 0 to Commadcaches.Count - 1 do
Commadcaches.Objects[I].Free;
finally
Commandlist.Unlock;
end;
Commandlist.Free;
end;
inherited;
end;
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Startercommand : String;
Params: array [1 .. 200] of String;
Cache, OutboundCmds: TStringList;
ParamsCount, P: integer;
I: integer;
S: String;
DECODES : String;
UConnected : Boolean;
Len: Integer;
begin
Try
UConnected := AContext.Connection.Connected;
Except
UConnected := False;
End;
If Not UConnected Then
begin
AContext.Connection.Disconnect;
exit;
end;
Len := AContext.Connection.IOHandler.InputBuffer.Size;
If Len >= 200000 then
begin
AContext.Connection.Disconnect;
exit;
end;
Connection := AContext as TConnection;
// check for pending outbound commands...
OutboundCmds := nil;
try
Cache := Connection.OutboundCache.Lock;
try
if Cache.Count > 0 then
begin
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
end;
finally
Connection.OutboundCache.Unlock;
end;
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
AContext.Connection.IOHandler.Writeln(OutboundCmds.Strings[I],
IndyTextEncoding_UTF8);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
AContext.Connection.IOHandler.LargeStream := true;
AContext.Connection.IOHandler.Write(MS, 0, true);
end;
end;
Connection.LastSendRecv := Ticks64;
end;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
// check for a pending inbound command...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(Connection.LastSendRecv) >= 60000 then
AContext.Connection.Disconnect;
Exit;
end;
end;
Startercommand := Decode64(AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8), IndyTextEncoding_UTF8);
Command := Startercommand;
{HERE I START TO CHECK COMMAND LIST}
if (command <> 'ISACTIVE') then
begin
if Connection.Verfieycmds(Command) <> true then
begin
AContext.Connection.Disconnect;
Exit;
end;
end;
{HERE I START TO CHECK COMMAND LIST}
Connection.LastSendRecv := Ticks64;
if Command = '' then
begin
AContext.Connection.Disconnect;
Exit;
end;
ReceiveParams := False;
ReceiveStream := False;
if Command[1] = '1' then // command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
ReceiveStream := true;
end;
if ReceiveParams then // params is incomming
begin
S := AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8);
DECODES := Decode64(S, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (DECODES <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, DECODES);
if P = 0 then
Params[ParamsCount] := DECODES
else
begin
Params[ParamsCount] := Copy(DECODES, 1, P - 1);
Delete(DECODES, 1, P + 5);
end;
end;
end;
if Command = 'Broadcastanymessage' then
begin
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
end;
if i remove the Verfieycmds from the execute check the server running normally . what i am doing wrong ?
There is no reason to use a TIdThreadSafeStringList for the commands list. Only the thread that creates the list will ever be accessing it, so using a lock for it is unnecessary overhead.
And there is no reason to allocate a new list for each client, for that matter. That is just wasting memory.
Your commands are encoded in a manner that requires decoding before you can then validate them.
Try something more like this instead:
type
TConnection = class(TIdServerContext)
private
function HasInboundData: Boolean;
procedure SendOutboundCache;
public
OutboundCache: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
// ...
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
//...
procedure TcpServerConnect(AContext: TIdContext);
//...
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCreate(Sender: TObject);
//...
private
//...
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
LastSendRecv := Ticks64;
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
inherited;
end;
function TConnection.HasInboundData: Boolean;
begin
if Connection.IOHandler.InputBufferIsEmpty then
begin
Connection.IOHandler.CheckForDataOnSource(100);
Connection.IOHandler.CheckForDisconnect;
if Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(LastSendRecv) >= 60000 then
Connection.Disconnect;
Result := False;
Exit;
end;
end;
Result := True;
end;
procedure TConnection.SendOutboundCache;
var
Cache, OutboundCmds: TStringList;
MS: TMemoryStream;
I: integer;
begin
OutboundCmds := nil;
try
Cache := OutboundCache.Lock;
try
if Cache.Count = 0 then
Exit;
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
finally
OutboundCache.Unlock;
end;
for I := 0 to OutboundCmds.Count - 1 do
begin
Connection.IOHandler.WriteLn(OutboundCmds.Strings[I]);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
Connection.IOHandler.LargeStream := true;
Connection.IOHandler.Write(MS, 0, true);
end;
end;
LastSendRecv := Ticks64;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
end;
procedure TServobj.FormCreate(Sender: TObject);
begin
TcpServer.ContextClass := TConnection;
end;
procedure TServobj.TcpServerConnect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8
end;
const
ValidCmds: array[0..13] of String = (
'ISACTIVE',
'Broadcastanymessage',
'Command1',
'Command2',
'Command3',
'Command4',
'Command5',
'Command6',
'Command7',
'Command8',
'Command9',
'Command10',
'Command11',
'Command12'
);
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command, Decoded: String;
Params: array[1..200] of String;
ParamsCount, P, I, WhichCmd: integer;
begin
Connection := AContext as TConnection;
// check for pending outbound commands...
Connection.SendOutboundCache;
// check for a pending inbound command...
if not Connection.HasInboundData then
Exit;
Command := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ReceiveParams := False;
ReceiveStream := False;
if Command <> '' then
begin
if Command[1] = '1' then // command with params
begin
Delete(Command, 1, 1);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Delete(Command, 1, 1);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Delete(Command, 1, 1);
ReceiveParams := true;
ReceiveStream := true;
end;
end;
WhichCmd := PosInStrArray(Command, ValidCmds);
if WhichCmd = -1 then
begin
AContext.Connection.Disconnect;
Exit;
end;
if ReceiveParams then // params is incomming
begin
Decoded := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (Decoded <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, Decoded);
if P = 0 then
Params[ParamsCount] := Decoded
else
begin
Params[ParamsCount] := Copy(Decoded, 1, P - 1);
Delete(Decoded, 1, P + Length(Sep));
end;
end;
end;
Connection.LastSendRecv := Ticks64;
case WhichCmd of
// process commands as needed...
1: begin // Broadcastanymessage
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
// ...
end;
end;

Oracle Error "Ora-06502 PL/SQL: numaric or value error: invalid LOB locate"

I'm getting this Oracle error Ora-06502 PL/SQL: numeric or value error: invalid LOB locate when two users try to commit at the same time.
I actually tried hard to solve this problem but I couldn't find a solution.
Please see the code for more details.
PROCEDURE CHECK_POP_DATA_PCC(RETURN_STATUS IN OUT NUMBER) IS LAST BOOLEAN;
REC_NUMBER NUMBER;
MESS_CTR NUMBER;
NO_DETAIL EXCEPTION;
SWF_FAIL EXCEPTION;
USA_STATUS NUMBER;
TEXT_STATUS NUMBER;
FIRST_ROUND NUMBER;
OERR NUMBER;
FILE_NAME VARCHAR2(100);
FILE_NAME1 VARCHAR2(100);
FILE_NAME2 VARCHAR2(100);
FILE_DIR VARCHAR2(100);
PRINT_ERR EXCEPTION;
PRINT_ERR1 EXCEPTION;
MESS_TEXT VARCHAR2(1000);
CTR NUMBER;
LEN NUMBER;
SUB NUMBER;
OPEN_TYPE NUMBER;
J NUMBER;
STR1 VARCHAR2(100);
STR2 VARCHAR2(100);
SPC NUMBER;
ESCP VARCHAR2(512);
FIRST_SEQ NUMBER;
REM NUMBER;
CLOSE_TYPE NUMBER;
SWF_ADD VARCHAR2(100);
SWF_PASS VARCHAR2(100);
SWF_UNAME VARCHAR2(100);
COMP_FILE TEXT_IO.FILE_TYPE;
FIRST_FILE TEXT_IO.FILE_TYPE;
SECOND_FILE TEXT_IO.FILE_TYPE;
cur_hdl integer;
rows_p integer;
tmp_chr VARCHAR2(2);
SWF_FTP_COM VARCHAR2(100);
File_status NUMBER;
ret_sta NUMBER;
key_all_data CLOB;
RTGS_IPADD VARCHAR2(100);
RTGS_FLA NUMBER (1,0);
RTGS_UNAME VARCHAR2(100);
RTGS_PASS VARCHAR2(100);
IS_SEC NUMBER ;
CURSOR C2 IS
SELECT MESS_TYPE_CODE,
SEQ_NUM,
FROM_SWF_CODE,
TO_SWF_CODE,
PRTY_CODE
FROM SWF_MESS
WHERE BRA_CODE = :SYS.BRA_CODE
AND REF_TYPE = :SYS.REF_TYPE
AND REF_YEAR = :SYS.REF_YEAR
AND REF_NUM = :SYS.REF_NUM
AND NVL(FILE_NUM,0) = :SYS.FILE_NUM
AND MESS_STA_CODE NOT IN (1,
2,
3,
5,
6,
7,
8);
BEGIN RET_STA := 0;
SELECT SWF_IPADDRESS,
SWF_USERNAME,
SWF_PASSWORD,
nvl(SWF_EOL_CHR,'CHR(10)'),
FTP_COM,
RTGS_IPADDRESS,
RTGS_FLAG,
RTGS_USERNAME,
RTGS_PASSWORD,
IS_SECURE INTO SWF_ADD,
SWF_UNAME,
SWF_PASS,
:TIT.EOL_SWF,
SWF_FTP_COM,
RTGS_IPADD,
RTGS_FLA,
RTGS_UNAME,
RTGS_PASS,
IS_SEC ---SHAZA(BANK/27/4540)
FROM web_par
WHERE app_ipaddress = nvl(:GLOBAL.APP_IPADDRESS,'0.0.0.0') ;
/* *************************************** */ FIRST_ROUND := 0;
RETURN_STATUS := 0;
FIRST_SEQ := 0;
key_all_data := '';
IF :GLOBAL.BRA_BRA_CODE = :GLOBAL.BAN_HO_REG_CODE THEN GO_BLOCK('SYS');
FIRST_RECORD;
LAST := FALSE;
WHILE NOT LAST LOOP IF :SYS.FLAG = 1 THEN
FOR C2REC IN C2 LOOP A07SWF00(:SYS.BRA_CODE,:SYS.REF_TYPE,:SYS.REF_YEAR,:SYS.REF_NUM, C2REC.MESS_TYPE_CODE,C2REC.SEQ_NUM,RETURN_STATUS);
IF RETURN_STATUS = 0 THEN
COMMIT;
CHECK_FRM_STATS;
ELSE RAISE SWF_FAIL;
END IF;
END LOOP;
END IF;
IF :SYSTEM.LAST_RECORD = 'TRUE' THEN LAST := TRUE;
ELSE NEXT_RECORD;
END IF;
END LOOP;
END IF;
/*****************************************************/ GO_BLOCK('SYS');
FIRST_RECORD;
LAST := FALSE;
WHILE NOT LAST LOOP IF :SYS.FLAG = 1 THEN key_all_data := '';
FIRST_ROUND := 0;
SELECT SWF_SEQ.NEXTVAL INTO :KEY.SWF_SEQ
FROM DUAL;
IF FIRST_SEQ = 0 THEN :KEY.FROM_SWF_SEQ := :KEY.SWF_SEQ;
FIRST_SEQ := 1;
END IF;
FOR C2REC IN C2 LOOP /*******************************/
SELECT COUNT(*) INTO MESS_CTR
FROM SWF_DETL
WHERE BRA_CODE = :SYS.BRA_CODE
AND REF_TYPE = :SYS.REF_TYPE
AND REF_YEAR = :SYS.REF_YEAR
AND REF_NUM = :SYS.REF_NUM
AND MESS_TYPE_CODE = C2REC.MESS_TYPE_CODE
AND SEQ_NUM = C2REC.SEQ_NUM;
IF MESS_CTR > 0 THEN CHECK_MESS_USA(:SYS.BRA_CODE,:SYS.REF_TYPE,:SYS.REF_YEAR, :SYS.REF_NUM,C2REC.MESS_TYPE_CODE,C2REC.SEQ_NUM, USA_STATUS);
IF USA_STATUS = 0 THEN CHECK_MESS_TEXT(C2REC.MESS_TYPE_CODE,C2REC.SEQ_NUM, C2REC.FROM_SWF_CODE,C2REC.TO_SWF_CODE, C2REC.PRTY_CODE,TEXT_STATUS);
IF TEXT_STATUS = 0 THEN A07SWF60 ( :sys.BRA_CODE, :sys.REF_TYPE, :sys.REF_YEAR, :sys.REF_NUM, c2rec.MESS_TYPE_CODE, c2rec.SEQ_NUM, :global.WST_TELL_ID, :key.SWF_SEQ, :GLOBAL.CLI_BANK_DATE, :SYS.ALL_DATA, RETURN_STATUS);
IF RETURN_STATUS <> 0 THEN RETURN_STATUS := -SQLCODE;
RETURN;
END IF;
UPDATE SWF_MESS
SET RTGS_FLAG = :SYS.RTGS_FLAG
WHERE BRA_CODE = :SYS.BRA_CODE
AND REF_TYPE = :SYS.REF_TYPE
AND REF_YEAR = :SYS.REF_YEAR
AND REF_NUM = :SYS.REF_NUM
AND MESS_TYPE_CODE = C2REC.MESS_TYPE_CODE
AND SEQ_NUM = C2REC.SEQ_NUM;
IF FIRST_ROUND = 0 THEN dbms_lob.createtemporary(key_all_data, TRUE);
dbms_lob.open(key_all_data, 1);
dbms_lob.append(key_all_data,:SYS.ALL_DATA);
FIRST_ROUND := 1;
ELSE ESCP := '';
IF :SYS.PRE_LEN <> 0 THEN REM := :SYS.PRE_LEN/512;
IF (REM - TRUNC(REM)) <> 0 THEN SPC := 512 - (:SYS.PRE_LEN - (TRUNC(REM) * 512));
FOR I IN 1..SPC LOOP ESCP := ESCP||CHR(32);
END LOOP;
END IF;
ELSE ESCP := '';
END IF;
/*********************************************/ dbms_lob.append(key_all_data,ESCP);
dbms_lob.append(key_all_data,:SYS.ALL_DATA);
END IF;
ELSE RETURN_STATUS := TEXT_STATUS;
RAISE SWF_FAIL;
END IF;
ELSE RETURN_STATUS := USA_STATUS;
RAISE SWF_FAIL;
END IF;
ELSE RAISE NO_DETAIL;
END IF;
END LOOP;
IF :TIT.INP_SECU_CODE = 2 THEN FILE_NAME := 'OUT'||LPAD(TO_CHAR(:KEY.SWF_SEQ),5,'0')||'.ABI';
ELSE --alliance
FILE_NAME := 'OUT'||LPAD(TO_CHAR(:KEY.SWF_SEQ),5,'0')||'.MSG';
END IF;
-- FILE_DIR := '/u/oracle/dev/spool';
--LEN := NVL(LENGTH(key_all_data), 0);
LEN := NVL(dbms_lob.getlength(key_all_data),0);--
CTR := LEN / 1000 ;
IF CTR <= 1 THEN CTR := 1;
SUB := LEN;
ELSE IF (CTR - TRUNC(CTR)) <> 0 THEN CTR := TRUNC(CTR) + 1;
END IF ;
SUB := 1000;
END IF;
OPEN_TYPE := 1;
J := 1;
IF :tit.eol_swf <> 'CHR(13)||CHR(10)' THEN BEGIN key_all_data := replace(key_all_data,chr(13)||chr(10),chr(substr(:tit.eol_swf,5,2)));
exception WHEN others THEN NULL;
END;
END IF;
comp_file := TEXT_IO.FOPEN(NAME_IN('GLOBAL.PRINT_PATH')||FILE_NAME, 'W');
FOR I IN 1..CTR LOOP MESS_TEXT := dbms_lob.substr(key_all_data,1000,j);--
TEXT_IO.PUT (comp_file, mess_text);
OPEN_TYPE := 2;
IF return_status = 0 THEN J := J + 1000;
ELSIF RETURN_STATUS IN(1196,
1197,
1198,
1199) THEN RAISE PRINT_ERR;
ELSE RAISE PRINT_ERR1;
END IF ;
END LOOP;
/************** CLOSING THE FILE *****************************/ IF :SYS.LEN <> 0 THEN REM := :SYS.LEN/512;
IF (REM - TRUNC(REM)) <> 0 THEN SPC := 512 - (:SYS.LEN - (TRUNC(REM) * 512));
CLOSE_TYPE := 1;
ELSE CLOSE_TYPE := 3;
END IF;
ELSE CLOSE_TYPE := 3;
END IF;
OERR := 0;
IF CLOSE_TYPE = 1 THEN
FOR I IN 1..SPC LOOP ESCP := CHR(32);
Text_IO.PUT(COMP_FILE,ESCP);
END LOOP;
END IF;
TEXT_IO.FCLOSE(comp_file);
RETURN_STATUS := OERR;
IF OERR <> 0 THEN IF OERR = 1199 THEN RAISE PRINT_ERR;
ELSE RAISE PRINT_ERR1;
END IF ;
END IF;
IF NVL(RTGS_FLA,0)=2
AND :SYS.RTGS_FLAG=1 THEN send_swf_mess(FILE_NAME, RTGS_IPADD, RTGS_UNAME, RTGS_PASS, SWF_FTP_COM,IS_SEC, RET_STA);
ELSE send_swf_mess(FILE_NAME, SWF_ADD, SWF_UNAME, SWF_PASS, SWF_FTP_COM, IS_SEC, RET_STA);
END IF;
:SYS.LEN := 0;
GO_BLOCK('SYS');
END IF;
IF :SYSTEM.LAST_RECORD = 'TRUE' THEN LAST := TRUE;
ELSE NEXT_RECORD;
END IF;
END LOOP;
dbms_lob.close(key_all_data);
FIRST_RECORD;
:KEY.TO_SWF_SEQ := :KEY.SWF_SEQ;
EXCEPTION WHEN FORM_TRIGGER_FAILURE THEN RAISE FORM_TRIGGER_FAILURE ;
WHEN NO_DETAIL THEN :TIT.COMMIT := 1;
ROLLDATA;
RETURN_STATUS := 374;
:GLOBAL.TAB_ENT := '0374';
DISPLAY_MSG;
RETURN;
WHEN SWF_FAIL THEN :TIT.COMMIT := 1;
ROLLDATA;
display_err(return_status);
RETURN;
WHEN PRINT_ERR THEN ROLLDATA;
:global.tab_ent :=return_status ;
display_msg ;
:TIT.COMMIT := 1 ;
WHEN PRINT_ERR1 THEN ROLLDATA;
display_err(return_status);
:TIT.COMMIT := 1 ;
WHEN OTHERS THEN :TIT.COMMIT := 1;
ROLLDATA;
RETURN_STATUS := -SQLCODE;
display_err(return_status);
RETURN;
END;
This is a screenshot of the error message that displays to one of the users whilst the other user sees Operation successful.
You will get that error if your C2 cursor doesn't find anything; the CLOB is never opened because you don't go into the loop, but you still do the dbms_lob.close, and that will throw that ORA-22275 error:
DECLARE
key_all_data CLOB;
BEGIN
dbms_lob.close(key_all_data);
END;
/
ORA-06502: PL/SQL: numeric or value error: invalid LOB locator specified: ORA-22275
You don't really need to open your temporary CLOB, which means you don't need to close it either; but you should free it either way. So you can remove the line:
dbms_lob.open(key_all_data, 1);
and change:
dbms_lob.close(key_all_data);
to:
if dbms_lob.istemporary(key_all_data) = 1 then
dbms_lob.freetemporary(key_all_data);
end if;
If you want to keep the open then test the close part too:
if dbms_lob.istemporary(key_all_data) = 1 then
if dbms_lob.isopen(key_all_data) = 1 then
dbms_lob.close(key_all_data);
end if;
dbms_lob.freetemporary(key_all_data);
end if;
You might think that if you you have created the temporary CLOB and opened it then it will be open and therefore can be closed; but this:
key_all_data := replace(...);
... is replacing one temporary CLOB with another, which is not explicitly open. You can look at the istemporary and isopen values to see what is happening. You could look at dbms_lob.fragment_replace etc. instead, or skip the open/close and don't worry about it...
It isn't clear if one call to this procedure is changing what the next call sees in the cursor (since the update doesn't seem to do anything) but the form or something this calls might be doing more work that does.
There are probably lots of other issues and comments - exception when others then null jumps out as a really bad idea - but they're getting a bit off-topic.
I think that you are trying append null values to clob variable.
declare
key_all_data clob := 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa';
v varchar2(10);
begin
begin
dbms_lob.append(key_all_data,v); -- exception
exception when others then
dbms_output.put_line(sqlerrm);
end;
for rec in ( select empty_clob() c from dual) loop -- run - ok
dbms_lob.append(key_all_data,rec.c);
end loop;
begin
for rec in ( select to_clob(null) c from dual) loop -- exception
dbms_lob.append(key_all_data,rec.c);
end loop;
exception when others then
dbms_output.put_line(sqlerrm);
end;
end;

How to simple change node's attribute value of XMLTYPE in Oracle 11g r2?

I just wanna to change in this XML (contained in XMLTYPE variable) all nodes named "ChildNode" with "Name"="B" attribute values to "C":
<RootNode>
<ChildNodes>
<ChildNode Name="A"/>
<ChildNode Name="B"/>
</ChildNodes>
</RootNode>
DECLARE
FXML XMLTYPE;
BEGIN
FXML := ...; -- see text before
-- what next?
END;
Thanks!
You can use updatexml function:
declare
fOrigXml XmlType := XmlType(
'<RootNode>
<ChildNodes>
<ChildNode Name="A"/>
<ChildNode Name="B"/>
</ChildNodes>
</RootNode>');
fResXml XmlType;
begin
select updatexml((fOrigXml), '/RootNode/ChildNodes/ChildNode[#Name="B"]/#Name', 'C') into fResXml from dual;
end;
One more:
SET SERVEROUTPUT ON;
DECLARE
DOC DBMS_XMLDOM.DOMDocument;
var XMLTYPE := XMLType('<RootNode>
<ChildNodes>
<ChildNode Name="A"/>
<ChildNode Name="B"/>
</ChildNodes>
</RootNode>');
xmlvalue CLOB;
PROCEDURE changeNameAttributes(
DOC dbms_xmldom.domdocument)
IS
nl dbms_xmldom.domnodelist;
v_clob CLOB;
LEN NUMBER;
n dbms_xmldom.domnode;
nodename VARCHAR2(4000);
nodevalue VARCHAR2(4000);
PROCEDURE changeAttributeB(
n dbms_xmldom.domnode)
IS
e dbms_xmldom.domelement;
dn dbms_xmldom.domnode;
nnm dbms_xmldom.domnamednodemap;
attrname VARCHAR2(100);
attrval VARCHAR2(100);
LEN NUMBER;
BEGIN
e := dbms_xmldom.makeelement(n); -- get all attributes of element
nnm := xmldom.getattributes(n);
IF(xmldom.isnull(nnm) = FALSE) THEN
LEN := dbms_xmldom.getlength(nnm); -- loop through attributes
FOR i IN 0 .. LEN -1
LOOP
dn := dbms_xmldom.item(nnm, i);
attrname := dbms_xmldom.getnodename(dn);
IF(attrname = 'Name' ) THEN
attrval := dbms_xmldom.getnodevalue(dn);
IF(attrval = 'B') THEN
dbms_xmldom.setnodevalue(dn,'C');
END IF;
END IF;
END LOOP;
END IF;
END changeAttributeB;
BEGIN
nl := dbms_xmldom.getelementsbytagname(DOC, '*');
LEN := dbms_xmldom.getlength(nl);
FOR i IN 0 .. LEN -1
LOOP
n := dbms_xmldom.item(nl, i);
nodename := dbms_xmldom.getnodename(n);
IF ( nodename = 'ChildNode') THEN
changeAttributeB(n);
END IF;
END LOOP;
END changeNameAttributes;
BEGIN
DOC := DBMS_XMLDOM.newDOMDocument(var);
--Before
DBMS_OUTPUT.PUT_LINE('BEFORE');
DBMS_LOB.createtemporary (xmlvalue, TRUE);
DBMS_XMLDOM.writeToClob(DOC, xmlvalue);
DBMS_OUTPUT.PUT_LINE(xmlvalue);
-- Modify
changeNameAttributes(DOC);
-- After
DBMS_OUTPUT.PUT_LINE('AFTER');
DBMS_XMLDOM.writeToClob(DOC, xmlvalue);
DBMS_OUTPUT.PUT_LINE(xmlvalue);
dbms_xmldom.freedocument(DOC);
END;
/
Here is one solution:
Declare
xml_nl DBMS_XMLDOM.DOMNodeList;
xml_node DBMS_XMLDOM.DOMNode;
xml_doc DBMS_XMLDOM.DOMDocument;
v_xml_clob CLOB;
v_name VARCHAR2(32767);
v_xml VARCHAR2(32767) :=
'<RootNode>
<ChildNodes>
<ChildNode Name="A"/>
<ChildNode Name="B"/>
</ChildNodes>
</RootNode>';
Begin
xml_doc := DBMS_XMLDOM.NewDOMDocument(XMLType.createXML(v_xml));
xml_nl := DBMS_XMLDOM.GetElementsByTagName(xml_doc, 'ChildNode');
FOR i IN 0 .. (DBMS_XMLDOM.getLength(xml_nl) - 1) LOOP
xml_node := DBMS_XMLDOM.Item(xml_nl, i);
DBMS_XSLPROCESSOR.valueOf(xml_node, '#Name', v_name);
IF v_name IS NOT NULL AND v_name = 'B' THEN
DBMS_XMLDOM.setAttribute(DBMS_XMLDOM.makeElement(xml_node), 'Name', 'C');
END IF;
END LOOP;
DBMS_LOB.createTemporary(v_xml_clob, cache => FALSE);
DBMS_LOB.Open(v_xml_clob, DBMS_LOB.lob_readwrite);
DBMS_XMLDOM.writeToCLob(xml_doc, v_xml_clob);
DBMS_OUTPUT.put_line(v_xml_clob);
End;
/* Formatted on 6/19/2016 3:02:05 PM (QP5 v5.126) */
DECLARE
var XMLTYPE;
doc DBMS_XMLDOM.domdocument;
ndoc DBMS_XMLDOM.domnode;
docelem DBMS_XMLDOM.domelement;
node DBMS_XMLDOM.domnode;
childnode DBMS_XMLDOM.domnode;
nodelist DBMS_XMLDOM.domnodelist;
nodelist2 DBMS_XMLDOM.domnodelist;
buf VARCHAR2 (2000);
newnode DBMS_XMLDOM.domnode;
clonenode DBMS_XMLDOM.domnode;
elem DBMS_XMLDOM.domelement;
PROCEDURE duyethoiquy (clonenode IN OUT DBMS_XMLDOM.domnode)
IS
childnode DBMS_XMLDOM.domnode;
simpletypechildnodemap DBMS_XMLDOM.domnamednodemap;
simpletypeattributenode DBMS_XMLDOM.domnode;
BEGIN
-- xu ly clonenode nay
-- sau do lay may con de duyet tiep
-- thay doi node con lev 1..
IF NOT DBMS_XMLDOM.isnull (clonenode)
THEN
-- xu ly node nay
-- thay doi mot vai thuoc tinh cua cay nay
simpletypechildnodemap := DBMS_XMLDOM.getattributes (clonenode);
simpletypeattributenode :=
DBMS_XMLDOM.getnameditem (simpletypechildnodemap, 'r');
IF NOT DBMS_XMLDOM.isnull (simpletypeattributenode)
THEN
DBMS_XMLDOM.setnodevalue (simpletypeattributenode, '');
DBMS_XMLDOM.writetobuffer (simpletypeattributenode, buf);
DBMS_OUTPUT.put_line ('attr:' || buf);
END IF;
IF DBMS_XMLDOM.haschildnodes (clonenode)
THEN
childnode := DBMS_XMLDOM.getfirstchild (clonenode);
--- ghi nhan gia tri
WHILE NOT DBMS_XMLDOM.isnull (childnode)
LOOP
-- xu ly con cua no:
duyethoiquy (childnode);
childnode := DBMS_XMLDOM.getnextsibling (childnode);
-------------------------------------
END LOOP;
ELSE -- is leaf
-- reset gia tri cua node duoc clone nay roi
DBMS_XMLDOM.setnodevalue (clonenode, '');
END IF;
END IF;
END;
BEGIN
var :=
xmltype('<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <worksheet xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"
xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships"
xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="x14ac"
xmlns:x14ac="http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac">
<sheetData>
<row r="1"><c r="A1" s="2" t="s"><v>0</v></c><c r="B1" s="2" t="s"><v>0</v></c></row>
<row r="3"><c r="A3" s="2" t="s"><v>1</v></c><c r="B3" s="2" t="s"><v>1</v></c></row>
</sheetData>
</worksheet>');
-- Create DOMDocument handle:
ndoc :=
DBMS_XMLDOM.makenode(DBMS_XMLDOM.getdocumentelement (
DBMS_XMLDOM.newdomdocument (var)));
newnode :=
DBMS_XMLDOM.makenode(DBMS_XMLDOM.getdocumentelement(DBMS_XMLDOM.newdomdocument(xmltype('<row r="2"><c r="A2" s="1" t="s"><v>0</v></c></row>'))));
-- ghi vao node
nodelist := DBMS_XSLPROCESSOR.selectnodes (ndoc, '/worksheet/sheetData');
IF NOT DBMS_XMLDOM.isnull (nodelist)
THEN
node := DBMS_XMLDOM.item (nodelist, 0);
childnode := DBMS_XMLDOM.getlastchild (node);
clonenode := DBMS_XMLDOM.clonenode (childnode, TRUE);
-- thay doi node cha
duyethoiquy (clonenode);
-- DBMS_XMLDOM.writetobuffer (newnode, buf);
-- DBMS_OUTPUT.put_line ('LastChild:' || buf);
elem :=
DBMS_XMLDOM.makeelement(DBMS_XMLDOM.appendchild (
node,
DBMS_XMLDOM.makenode(DBMS_XMLDOM.makeelement(DBMS_XMLDOM.importnode (
DBMS_XMLDOM.getownerdocument(node),
clonenode, --newnode,
TRUE)))));
END IF;
DBMS_XMLDOM.writetobuffer (ndoc, buf);
DBMS_OUTPUT.put_line ('After:' || buf);
END;
-- vi du voi xm;

Resources