|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 17408 (0x4400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Any_Object, seg_0267ec, seg_027c58, seg_027cf3, separate Directory
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Text_Io;
separate (Directory)
package body Any_Object is
procedure Open (The_Object : in out Object; Object_Name : String) is
O : Object;
Result : Boolean;
begin
if Di.Existent_Entry (Path => Object_Name) then
if Directory.Naming.Absolute (The_Name => Object_Name) then
Gs.Create (O.Name, Object_Name);
else
Gs.Create (O.Name,
Directory.Naming.Absolute_Name (Object_Name));
end if;
The_Object := O;
else
raise Non_Existent_Object_Error;
end if;
end Open;
procedure Create (The_Object : in out Object;
Object_Name : String;
Object_Class : Class_Enumeration :=
Directory.Unknown_Class;
Object_Owner_Permissions :
Statistics.Permission_Enumeration :=
Directory.Statistics.R_W_Permission;
Object_Group_Permissions :
Statistics.Permission_Enumeration :=
Directory.Statistics.R_W_Permission;
Object_Other_Permissions :
Statistics.Permission_Enumeration :=
Directory.Statistics.R_W_Permission) is
O : Object;
Result : Boolean;
begin
if Di.Existent_Entry (Path => Object_Name) then
raise Already_Existent_Object_Error;
else
case Object_Class is
when Directory_Class =>
if Di.Create_Directory
(Path => Object_Name,
Owner_Permissions => Object_Owner_Permissions,
Group_Permissions => Object_Group_Permissions,
Other_Permissions => Object_Other_Permissions) then
if Naming.Absolute (Object_Name) then
Gs.Create (O.Name, Object_Name);
else
Gs.Create (O.Name,
Naming.Absolute_Name (Object_Name));
end if;
else
Put_Error_Message;
raise System_Error;
end if;
when File_Class =>
if Di.Create_File (Path => Object_Name,
Owner_Permissions =>
Object_Owner_Permissions,
Group_Permissions =>
Object_Group_Permissions,
Other_Permissions =>
Object_Other_Permissions) then
if Naming.Absolute (Object_Name) then
Gs.Create (O.Name, Object_Name);
else
Gs.Create (O.Name,
Naming.Absolute_Name (Object_Name));
end if;
else
Put_Error_Message;
raise System_Error;
end if;
when others =>
Put_Error_Message
(The_Message =>
"You can only create directories or regular files");
raise System_Error;
end case;
The_Object := O;
end if;
end Create;
procedure Copy (Source : Object;
Destination_Name : in String;
Destination : in out Object) is
O : Object;
begin
if Naming.Absolute (Destination_Name) then
Gs.Create (O.Name, Destination_Name);
else
Gs.Create (O.Name, Naming.Absolute_Name (Destination_Name));
end if;
case Class (Source) is
when File_Class =>
if not Di.Copy_File (The_Path =>
Naming.Full_Name (The_Object => Source),
To_Path => Naming.Full_Name
(The_Object => O)) then
Put_Error_Message;
raise System_Error;
end if;
when Directory_Class =>
if not Di.Copy_Directory
(The_Path => Naming.Full_Name (The_Object => Source),
To_Path => Naming.Full_Name (The_Object => O)) then
Put_Error_Message;
raise System_Error;
end if;
when others =>
Put_Error_Message
(The_Message =>
"Only directories and regular files can be copied");
raise System_Error;
end case;
Destination := O;
end Copy;
procedure Rename (Source : in out Object; Destination_Name : in String) is
O : Object;
begin
if Naming.Absolute (Destination_Name) then
Gs.Create (O.Name, Destination_Name);
else
Gs.Create (O.Name, Naming.Absolute_Name (Destination_Name));
end if;
if not Di.Move (The_Path => Naming.Full_Name (Source),
To_Path => Naming.Full_Name (O)) then
Put_Error_Message;
raise System_Error;
end if;
Source := O;
end Rename;
procedure Delete (The_Object : in out Object) is
Ok : Boolean;
begin
case Class (The_Object) is
when Directory_Class =>
Ok := Di.Delete_Directory (Path =>
Naming.Full_Name (The_Object));
when others =>
Ok := Di.Delete_File (Path => Naming.Full_Name (The_Object));
end case;
if not Ok then
Put_Error_Message;
raise System_Error;
end if;
The_Object := Nil;
end Delete;
end Any_Object;
nblk1=10
nid=3
hdr6=12
[0x00] rec0=1c rec1=00 rec2=01 rec3=024
[0x01] rec0=00 rec1=00 rec2=04 rec3=00a
[0x02] rec0=13 rec1=00 rec2=0d rec3=06c
[0x03] rec0=00 rec1=00 rec2=08 rec3=00a
[0x04] rec0=13 rec1=00 rec2=0b rec3=018
[0x05] rec0=18 rec1=00 rec2=0e rec3=048
[0x06] rec0=15 rec1=00 rec2=10 rec3=04c
[0x07] rec0=1d rec1=00 rec2=05 rec3=028
[0x08] rec0=13 rec1=00 rec2=06 rec3=000
[0x09] rec0=03 rec1=00 rec2=03 rec3=000
[0x0a] rec0=1b rec1=00 rec2=08 rec3=05e
[0x0b] rec0=1e rec1=00 rec2=06 rec3=000
[0x0c] rec0=09 rec1=00 rec2=0a rec3=000
[0x0d] rec0=00 rec1=00 rec2=00 rec3=000
[0x0e] rec0=00 rec1=00 rec2=00 rec3=000
[0x0f] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x217211db883ab3e280e01 0x42a00088462062803
Free Block Chain:
0x3: 0000 00 0c 00 09 80 06 63 74 29 20 69 73 06 07 20 20 ┆ ct) is ┆
0xc: 0000 00 0f 00 12 80 06 62 6a 65 63 74 3b 06 00 00 00 ┆ bject; ┆
0xf: 0000 00 0a 00 08 80 05 72 5f 50 65 72 05 6c 61 72 20 ┆ r_Per lar ┆
0xa: 0000 00 07 03 fc 00 35 20 20 20 20 20 20 20 20 20 20 ┆ 5 ┆
0x7: 0000 00 09 00 0d 80 0a 20 20 20 20 20 20 20 20 20 20 ┆ ┆
0x9: 0000 00 02 00 32 00 26 20 20 20 20 20 20 20 20 20 20 ┆ 2 & ┆
0x2: 0000 00 00 00 e2 80 21 20 20 20 20 20 20 20 20 20 20 ┆ ! ┆