search in multilevel linked lists in Pascal - data-structures

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.

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

Monotone chain change data structure to doubly linked list

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

Pascal: Will not read anything from my file and getting errors

I've been stressing out for the past few hours trying to get this working and I simply cannot figure it out. Basically it doesn't read anything from my .dat file and when I try to use options 2, 3 or 4 it just comes up with these
.
I've include the .dat file and pascal below. I'm desperate for help.
mytestfile.dat
1
Adele
Pop
2
Hello
ff
Remedy
dd
pascal
program MusicPlayer;
uses TerminalUserInput;
type
TrackRec = record
name: String;
location: String;
end;
// type TrackArray = array of TrackRec;
GenreType = (Pop, Rap, Rock, Classic);
AlbumRec = Record
name: String;
genre: GenreType;
// location: array of TrackRec;
tracks: array of TrackRec;
end;
type AlbumArray = array of AlbumRec;
function ReadGenre(): GenreType;
var
option: Integer;
begin
WriteLn('Press 1 for Pop');
WriteLn('Press 2 for Rap');
WriteLn('Press 3 for Rock');
WriteLn('Press 4 for Classic');
option := ReadInteger('');
while (option<1) or (option>5) do
begin
WriteLn('Please enter a number between 1-4');
option := ReadInteger('');
end;
case option of
1: result := Pop;
2: result := Rap;
3: result := Rock;
else
result := Classic;
end;
end;
procedure NewAlbum(var albums: AlbumArray; var myFile: TextFile);
var
number, i, tracks, y: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
ReWrite(myFile);
number := ReadInteger('How many albums do you want to make?: ');
WriteLn(myFile, number);
SetLength(albums, number);
for i := Low(albums) to High(albums) do
begin
albums[i].name := ReadString('Enter album name:');
WriteLn(myFile, albums[i].name);
albums[i].genre := ReadGenre();
WriteLn(myFile, albums[i].genre);
tracks := ReadIntegerRange('How many tracks do you want to enter? (max 15)', 0, 15);
WriteLn(myFile, tracks);
SetLength(albums[i].tracks, tracks);
for y := Low(albums[i].tracks) to tracks - 1 do
begin
albums[i].tracks[i].name := ReadString('Track name:');
WriteLn(myFile, albums[i].tracks[i].name);
albums[i].tracks[i].location := ReadString('Track Location:');
WriteLn(myFile, albums[i].tracks[i].location);
end;
end;
Close(myFile);
end;
procedure ReadTrack(count: Integer; var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadLn(myFile, i);
SetLength(albums[count].tracks, i);
for count := Low(albums[count].tracks) to High(albums[count].tracks) - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
procedure ReadAlbum(var albums: AlbumArray; var myFile: TextFile);
var
albumNumber, tracknumber, count, i: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
Reset(myFile);
ReadLn(myFile, albumNumber);
SetLength(albums, albumNumber);
for i := Low(albums) to High(albums) do
begin
ReadLn(myFile, albums[i].name);
ReadLn(myFile, albums[i].genre);
ReadLn(myFile, tracknumber);
SetLength(albums[i].tracks, tracknumber);
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
end;
procedure ReadAlbums(var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbum(albums, myFile);
WriteLn('Album is:');
for i := Low(albums) to High(albums) do
begin
WriteLn((i + 1),'.', albums[i].name);
WriteLn('.', albums[i].genre);
for number := Low(albums[i].tracks) to High(albums[i].tracks) do
begin
WriteLn((number + 1), '', albums[i].tracks[Low(albums[i].tracks)].name);
end;
end;
end;
procedure PlayAlbum (var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Please select an album: ');
i := i - 1;
number := ReadIntegerRange('Please select a song from album:', 1, 20);
number := number - 1;
WriteLn('Now playing');
WriteLn('Track selected: ', albums[i].tracks[number].name);
WriteLn('Album: ', albums[i].name);
end;
procedure Update(var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Select an album to update');
i := i - 1;
albums[i].name := ReadString('New Album Name:');
WriteLn('Album has now been updated');
end;
procedure Main();
var
i, count, select, change: Integer;
albums: AlbumArray;
myFile: TextFile;
begin
WriteLn('Please select an option: ');
WriteLn('-------------------------');
WriteLn('1. Read Albums');
WriteLn('2. Display Albums');
WriteLn('3. Select an Album');
WriteLn('4. Update an Album');
WriteLn('5. Exit');
WriteLn('-------------------------');
repeat
i := ReadInteger('Select option for menu:');
case i of
1: ReadAlbum(albums, myFile);
2: ReadAlbums(albums, myFile);
3: PlayAlbum(albums, myFile);
4: Update(albums, myFile);
end;
until i = 5;
end;
begin
Main();
end.
In the ReadAlbum() procedure you have two for loops, an outer one that loops through the albums and an inner one that loops through the tracks. In the latter you have messed up the indexes:
This is the erroneous code:
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
albums[] should use i as index and tracks[] should use count as index.
Until you get more used to arrays and indexes I suggest you name your variables with a clear meaning, for example:
`NumOfAlbums` in the meaning of how many albums you have
`AlbumIndex` as the index to the albums array
`NumOfTracks` as the number of tracks in an album
`TrackIndex` as the index to the tracks array
It may feel tiresome to write so long names, but you would probably not have made the mistake you did, with the more verbose names.

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;

Resources