1------------------------------------------------------------------------------ 2-- -- 3-- APQ DATABASE BINDINGS -- 4-- -- 5-- A P Q - POSTGRESQL -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- 10-- Copyright (C) 2007-2009, Ada Works Project -- 11-- -- 12-- -- 13-- APQ is free software; you can redistribute it and/or modify it under -- 14-- terms of the GNU General Public License as published by the Free Soft- -- 15-- ware Foundation; either version 2, or (at your option) any later ver- -- 16-- sion. APQ is distributed in the hope that it will be useful, but WITH- -- 17-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 18-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 19-- for more details. You should have received a copy of the GNU General -- 20-- Public License distributed with APQ; see file COPYING. If not, write -- 21-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 22-- MA 02111-1307, USA. -- 23-- -- 24-- As a special exception, if other files instantiate generics from this -- 25-- unit, or you link this unit with other files to produce an executable, -- 26-- this unit does not by itself cause the resulting executable to be -- 27-- covered by the GNU General Public License. This exception does not -- 28-- however invalidate any other reasons why the executable file might be -- 29-- covered by the GNU Public License. -- 30------------------------------------------------------------------------------ 31 32with Ada.Exceptions; 33with Ada.Calendar; 34with Ada.Unchecked_Deallocation; 35with Ada.Unchecked_Conversion; 36with Ada.Characters.Latin_1; 37with Ada.Characters.Handling; 38with Ada.Strings.Fixed; 39with Ada.IO_Exceptions; 40with System; 41with System.Address_To_Access_Conversions; 42with Interfaces.C.Strings; 43with GNAT.OS_Lib; 44 45use Interfaces.C; 46use Ada.Exceptions; 47 48package body APQ.PostgreSQL.Client is 49 50 Seek_Set : constant Interfaces.C.int := 0; 51 Seek_Cur : constant Interfaces.C.int := 1; 52 Seek_End : constant Interfaces.C.int := 2; 53 54 No_Date : Ada.Calendar.Time; 55 56 type PQ_Status_Type is ( 57 Connection_OK, 58 Connection_Bad, 59 Connection_Started, -- Waiting for connection to be made. 60 Connection_Made, -- Connection OK; waiting to send. 61 Connection_Awaiting_Response, -- Waiting for a response 62 Connection_Auth_OK, -- Received authentication 63 Connection_Setenv -- Negotiating environment. 64 ); 65 66 for PQ_Status_Type use ( 67 0, -- CONNECTION_OK 68 1, -- CONNECTION_BAD 69 2, -- CONNECTION_STARTED 70 3, -- CONNECTION_MADE 71 4, -- CONNECTION_AWAITING_RESPONSE 72 5, -- CONNECTION_AUTH_OK 73 6 -- CONNECTION_SETENV 74 ); 75 76 77 ------------------------------ 78 -- DATABASE CONNECTION : 79 ------------------------------ 80 81 82 function Engine_Of(C : Connection_Type) return Database_Type is 83 begin 84 return Engine_PostgreSQL; 85 end Engine_Of; 86 87 88 89 function New_Query(C : Connection_Type) return Root_Query_Type'Class is 90 Q : Query_Type; 91 begin 92 return Q; 93 end New_Query; 94 95 96 97 procedure Notify_on_Standard_Error(C : in out Connection_Type; Message : String) is 98 use Ada.Text_IO; 99 begin 100 Put(Standard_Error,"*** NOTICE : "); 101 Put_Line(Standard_Error,Message); 102 end Notify_on_Standard_Error; 103 104 105 106 procedure Set_Instance(C : in out Connection_Type; Instance : String) is 107 begin 108 Raise_Exception(Not_Supported'Identity, 109 "PG01: PostgreSQL has no Instance ID. (Set_Instance)"); 110 end Set_Instance; 111 112 113 114 function Host_Name(C : Connection_Type) return String is 115 begin 116 if not Is_Connected(C) then 117 return Host_Name(Root_Connection_Type(C)); 118 else 119 declare 120 use Interfaces.C.Strings; 121 function PQhost(PGconn : PG_Conn) return chars_ptr; 122 pragma Import(C,PQhost,"PQhost"); 123 124 The_Host : chars_ptr := PQhost(C.Connection); 125 begin 126 if The_Host = Null_Ptr then 127 return "localhost"; 128 end if; 129 return Value_Of(The_Host); 130 end; 131 end if; 132 end Host_Name; 133 134 135 136 function Port(C : Connection_Type) return Integer is 137 begin 138 if not Is_Connected(C) then 139 return Port(Root_Connection_Type(C)); 140 else 141 declare 142 use Interfaces.C.Strings; 143 function PQport(PGconn : PG_Conn) return chars_ptr; 144 pragma Import(C,PQport,"PQport"); 145 146 The_Port : String := Value_Of(PQport(C.Connection)); 147 begin 148 return Integer'Value(The_Port); 149 exception 150 when others => 151 Raise_Exception(Invalid_Format'Identity, 152 "PG02: Invalid port number or is a UNIX socket reference (Port)."); 153 end; 154 end if; 155 156 return 0; 157 end Port; 158 159 160 161 function Port(C : Connection_Type) return String is 162 begin 163 if not Is_Connected(C) then 164 return Port(Root_Connection_Type(C)); 165 else 166 declare 167 use Interfaces.C.Strings; 168 function PQport(PGconn : PG_Conn) return chars_ptr; 169 pragma Import(C,PQport,"PQport"); 170 begin 171 return Value_Of(PQport(C.Connection)); 172 end; 173 end if; 174 175 end Port; 176 177 178 179 function DB_Name(C : Connection_Type) return String is 180 begin 181 if not Is_Connected(C) then 182 return To_Case(DB_Name(Root_Connection_Type(C)),C.SQL_Case); 183 else 184 declare 185 use Interfaces.C.Strings; 186 function PQdb(PGconn : PG_Conn) return chars_ptr; 187 pragma Import(C,PQdb,"PQdb"); 188 begin 189 return Value_Of(PQdb(C.Connection)); 190 end; 191 end if; 192 193 end DB_Name; 194 195 196 197 function User(C : Connection_Type) return String is 198 begin 199 if not Is_Connected(C) then 200 return User(Root_Connection_Type(C)); 201 else 202 declare 203 use Interfaces.C.Strings; 204 function PQuser(PGconn : PG_Conn) return chars_ptr; 205 pragma Import(C,PQuser,"PQuser"); 206 begin 207 return Value_Of(PQuser(C.Connection)); 208 end; 209 end if; 210 end User; 211 212 213 214 function Password(C : Connection_Type) return String is 215 begin 216 if not Is_Connected(C) then 217 return Password(Root_Connection_Type(C)); 218 else 219 declare 220 use Interfaces.C.Strings; 221 function PQpass(PGconn : PG_Conn) return chars_ptr; 222 pragma Import(C,PQpass,"PQpass"); 223 begin 224 return Value_Of(PQpass(C.Connection)); 225 end; 226 end if; 227 end Password; 228 229 230 231 procedure Set_DB_Name(C : in out Connection_Type; DB_Name : String) is 232 233 procedure Use_Database(C : in out Connection_Type; DB_Name : String) is 234 Q : Query_Type; 235 begin 236 begin 237 Prepare(Q,To_Case("USE " & DB_Name,C.SQL_Case)); 238 Execute(Q,C); 239 exception 240 when SQL_Error => 241 Raise_Exception(APQ.Use_Error'Identity, 242 "PG03: Unable to select database " & DB_Name & ". (Use_Database)"); 243 end; 244 end Use_Database; 245 246 begin 247 if not Is_Connected(C) then 248 -- Modify context to connect to this database when we connect 249 Set_DB_Name(Root_Connection_Type(C),DB_Name); 250 else 251 -- Use this database now 252 Use_Database(C,DB_Name); 253 -- Update context info if no exception thrown above 254 Set_DB_Name(Root_Connection_Type(C),DB_Name); 255 end if; 256 end Set_DB_Name; 257 258 259 260 procedure Set_Options(C : in out Connection_Type; Options : String) is 261 begin 262 Replace_String(C.Options,Set_Options.Options); 263 end Set_Options; 264 265 266 267 function Options(C : Connection_Type) return String is 268 begin 269 if not Is_Connected(C) then 270 if C.Options /= null then 271 return C.Options.all; 272 end if; 273 else 274 declare 275 use Interfaces.C.Strings; 276 function PQoptions(PGconn : PG_Conn) return chars_ptr; 277 pragma Import(C,PQoptions,"PQoptions"); 278 begin 279 return Value_Of(PQoptions(C.Connection)); 280 end; 281 end if; 282 return ""; 283 end Options; 284 285 286 287 procedure Set_Notify_Proc(C : in out Connection_Type; Notify_Proc : Notify_Proc_Type) is 288 begin 289 C.Notify_Proc := Set_Notify_Proc.Notify_Proc; 290 end Set_Notify_Proc; 291 292 293 294 function Notify_Proc(C : Connection_Type) return Notify_Proc_Type is 295 begin 296 return C.Notify_Proc; 297 end Notify_Proc; 298 299 300 -------------------------------------------------- 301 -- Connection_Notify is called by notices.c as 302 -- a callback from the libpq interface. 303 -------------------------------------------------- 304 procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr); 305 pragma Export(C,Connection_Notify,"Connection_Notify"); 306 307 308 procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr) is 309 use Interfaces.C.Strings; 310 package Addr is new System.Address_To_Access_Conversions(Connection_Type); 311 312 function Strip_Prefix(S : String) return String is 313 use Ada.Strings.Fixed, Ada.Strings; 314 begin 315 if S(S'First..S'First+6) = "NOTICE:" then 316 return Trim(S(S'First+7..S'Last),Left); 317 end if; 318 return S; 319 end Strip_Prefix; 320 321 Abrt_Notice : constant String := "current transaction is aborted, queries ignored until end of transaction block"; 322 Conn : Addr.Object_Pointer := Addr.To_Pointer(C_Addr); 323 Msg : String := Strip_Prefix(Strip_NL(To_Ada_String(Msg_Ptr))); 324 begin 325 if Conn.Notice /= null then 326 Free(Conn.Notice); -- Free last notice 327 end if; 328 -- Store new notice 329 Conn.Notice := new String(1..Msg'Length); 330 Conn.Notice.all := Msg; 331 332 if Conn.Notice.all = Abrt_Notice then 333 Conn.Abort_State := True; 334 end if; 335 336 if Conn.Notify_Proc /= Null then 337 Conn.Notify_Proc(Conn.all,Conn.Notice.all); 338 end if; 339 340 end Connection_Notify; 341 342 343 344 function PQ_Status(C : Connection_Type) return PQ_Status_Type is 345 function PQstatus(C : PG_Conn) return PQ_Status_Type; 346 pragma Import(C,PQstatus,"PQstatus"); 347 begin 348 if C.Connection = Null_Connection then 349 return Connection_Bad; 350 else 351 return PQstatus(C.Connection); 352 end if; 353 end PQ_Status; 354 355 356 357 procedure Connect(C : in out Connection_Type; Check_Connection : Boolean := True) is 358 procedure Notice_Install(Conn : PG_Conn; ada_obj_ptr : System.Address); 359 pragma import(C,Notice_Install,"notice_install"); 360 function PQsetdbLogin(pghost, pgport, pgoptions, pgtty, dbname, login, pwd : System.Address) return PG_Conn; 361 pragma import(C,PQsetdbLogin,"PQsetdbLogin"); 362 363 use Interfaces.C.Strings; 364 365 C_Host : char_array_access; 366 A_Host : System.Address := System.Null_Address; 367 C_Options : char_array_access; 368 A_Options : System.Address := System.Null_Address; 369 C_Tty : char_array_access; 370 A_Tty : System.Address := System.Null_Address; 371 C_Dbname : char_array_access; 372 A_Dbname : System.Address := System.Null_Address; 373 C_Login : char_array_access; 374 A_Login : System.Address := System.Null_Address; 375 C_Pwd : char_array_access; 376 A_Pwd : System.Address := System.Null_Address; 377 378 begin 379 380 if Check_Connection and then Is_Connected(C) then 381 Raise_Exception(Already_Connected'Identity, 382 "PG07: Already connected (Connect)."); 383 end if; 384 385 C_String(C.Host_Name,C_Host,A_Host); 386 C_String(C.Options,C_Options,A_Options); 387 C_String(null,C_Tty,A_Tty); 388 C_String(C.DB_Name,C_Dbname,A_Dbname); 389 C_String(C.User_Name,C_Login,A_Login); 390 C_String(C.User_Password,C_Pwd,A_Pwd); 391 392 if C.Port_Format = IP_Port then 393 declare 394 C_Port : char_array := To_C(Port_Integer'Image(C.Port_Number)); 395 A_Port : System.Address := C_Port'Address; 396 begin 397 -- Use application specified port # 398 C.Connection := PQsetdbLogin(A_Host,A_Port,A_Options,A_Tty,A_Dbname,A_Login,A_Pwd); 399 end; 400 elsif C.Port_Format = UNIX_Port then 401 declare 402 C_Port : char_array_access; 403 A_Port : System.Address := System.Null_Address; 404 begin 405 C_String(C.Port_Name,C_Port,A_Port); 406 C.Connection := PQsetdbLogin(A_Host,A_Port,A_Options,A_Tty,A_Dbname,A_Login,A_Pwd); 407 end; 408 else 409 raise Program_Error; 410 end if; 411 412 if C_Host /= null then 413 Free(C_Host); 414 end if; 415 if C_Options /= null then 416 Free(C_Options); 417 end if; 418 if C_Tty /= null then 419 Free(C_Tty); 420 end if; 421 if C_Dbname /= null then 422 Free(C_Dbname); 423 end if; 424 if C_Login /= null then 425 Free(C_Login); 426 end if; 427 if C_Pwd /= null then 428 Free(C_Pwd); 429 end if; 430 431 Free_Ptr(C.Error_Message); 432 433 if PQ_Status(C) /= Connection_OK then 434 declare 435 procedure PQfinish(C : PG_Conn); 436 pragma Import(C,PQfinish,"PQfinish"); 437 Msg : String := Strip_NL(Error_Message(C)); 438 begin 439 PQfinish(C.Connection); 440 C.Connection := Null_Connection; 441 C.Error_Message := new String(1..Msg'Length); 442 C.Error_Message.all := Msg; 443 Raise_Exception(Not_Connected'Identity, 444 "PG08: Failed to connect to database server (Connect)."); 445 end; 446 end if; 447 448 Notice_Install(C.Connection,C'Address); -- Install Connection_Notify handler 449 450 ------------------------------ 451 -- SET PGDATESTYLE TO ISO; 452 -- 453 -- This is necessary for all of the 454 -- APQ date handling routines to 455 -- function correctly. This implies 456 -- that all APQ applications programs 457 -- should use the ISO date format. 458 ------------------------------ 459 declare 460 SQL : Query_Type; 461 begin 462 Prepare(SQL,"SET DATESTYLE TO ISO"); 463 Execute(SQL,C); 464 exception 465 when Ex : others => 466 Disconnect(C); 467 Reraise_Occurrence(Ex); 468 end; 469 470 end Connect; 471 472 473 474 procedure Connect(C : in out Connection_Type; Same_As : Root_Connection_Type'Class) is 475 type Info_Func is access function(C : Connection_Type) return String; 476 477 procedure Clone(S : in out String_Ptr; Get_Info : Info_Func) is 478 Info : String := Get_Info(Connection_Type(Same_As)); 479 begin 480 if Info'Length > 0 then 481 S := new String(1..Info'Length); 482 S.all := Info; 483 else 484 null; 485 pragma assert(S = null); 486 end if; 487 end Clone; 488 begin 489 Reset(C); 490 491 Clone(C.Host_Name,Host_Name'Access); 492 493 C.Port_Format := Same_As.Port_Format; 494 if C.Port_Format = IP_Port then 495 C.Port_Number := Port(Same_As); -- IP_Port 496 else 497 Clone(C.Port_Name,Port'Access); -- UNIX_Port 498 end if; 499 500 Clone(C.DB_Name,DB_Name'Access); 501 Clone(C.User_Name,User'Access); 502 Clone(C.User_Password,Password'Access); 503 Clone(C.Options,Options'Access); 504 505 C.Rollback_Finalize := Same_As.Rollback_Finalize; 506 C.Notify_Proc := Connection_Type(Same_As).Notify_Proc; 507 508 Connect(C); -- Connect to database before worrying about trace facilities 509 510 -- TRACE FILE & TRACE SETTINGS ARE NOT CLONED 511 512 end Connect; 513 514 515 516 procedure Disconnect(C : in out Connection_Type) is 517 procedure Notice_Uninstall(C : PG_Conn); 518 pragma Import(C,notice_uninstall,"notice_uninstall"); 519 procedure PQfinish(C : PG_Conn); 520 pragma Import(C,PQfinish,"PQfinish"); 521 begin 522 523 if not Is_Connected(C) then 524 Raise_Exception(Not_Connected'Identity, 525 "PG09: Not connected. (Disconnect)"); 526 end if; 527 528 Notice_Uninstall(C.Connection); -- Disconnect callback notices 529 PQfinish(C.Connection); -- Now release the connection 530 C.Connection := Null_Connection; 531 C.Abort_State := False; -- Clear abort state 532 C.Notify_Proc := null; -- De-register the notify procedure 533 534 if C.Trace_Mode = Trace_APQ or else C.Trace_Mode = Trace_Full then 535 Ada.Text_IO.Put_Line(C.Trace_Ada,"-- DISCONNECT"); 536 end if; 537 538 Reset(C); 539 540 end Disconnect; 541 542 543 544 function Is_Connected(C : Connection_Type) return Boolean is 545 begin 546 return PQ_Status(C) = Connection_OK; 547 end Is_Connected; 548 549 550 551 procedure Internal_Reset(C : in out Connection_Type; In_Finalize : Boolean := False) is 552 begin 553 Free_Ptr(C.Error_Message); 554 555 if C.Connection /= Null_Connection then 556 declare 557 Q : Query_Type; 558 begin 559 Clear_Abort_State(C); 560 if C.Rollback_Finalize or In_Abort_State(C) then 561 if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then 562 Ada.Text_IO.Put_Line(C.Trace_Ada,"-- ROLLBACK ON FINALIZE"); 563 end if; 564 Rollback_Work(Q,C); 565 else 566 if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then 567 Ada.Text_IO.Put_Line(C.Trace_Ada,"-- COMMIT ON FINALIZE"); 568 end if; 569 Commit_Work(Q,C); 570 end if; 571 exception 572 when others => 573 null; -- Ignore if the Rollback/commit fails 574 end; 575 576 Clear_Abort_State(C); 577 578 Disconnect(C); 579 580 if C.Trace_Filename /= null then 581 Close_DB_Trace(C); 582 end if; 583 584 end if; 585 586 if C.Connection = Null_Connection then 587 Free_Ptr(C.Host_Name); 588 Free_Ptr(C.Host_Address); 589 Free_Ptr(C.DB_Name); 590 Free_Ptr(C.User_Name); 591 Free_Ptr(C.User_Password); 592 Free_Ptr(C.Options); 593 Free_Ptr(C.Error_Message); 594 Free_Ptr(C.Notice); 595 end if; 596 end Internal_Reset; 597 598 599 600 procedure Reset(C : in out Connection_Type) is 601 begin 602 Internal_Reset(C,In_Finalize => False); 603 end Reset; 604 605 606 607 function Error_Message(C : Connection_Type) return String is 608 function PQerrorMessage(C : PG_Conn) return Interfaces.C.Strings.chars_ptr; 609 pragma Import(C,PQerrorMessage,"PQerrorMessage"); 610 begin 611 if C.Connection = Null_Connection then 612 if C.Error_Message /= null then 613 return C.Error_Message.all; 614 else 615 return ""; 616 end if; 617 else 618 return To_Ada_String(PQerrorMessage(C.Connection)); 619 end if; 620 end Error_Message; 621 622 623 624 function Notice_Message(C : Connection_Type) return String is 625 begin 626 if C.Notice /= null then 627 return C.Notice.all; 628 end if; 629 return ""; 630 end Notice_Message; 631 632 633 634 procedure Open_DB_Trace(C : in out Connection_Type; Filename : String; Mode : Trace_Mode_Type := Trace_APQ) is 635 begin 636 if C.Trace_Filename /= null then 637 Raise_Exception(Tracing_State'Identity, 638 "PG04: Already in a tracing state (Open_DB_Trace)."); 639 end if; 640 641 if not Is_Connected(C) then 642 Raise_Exception(Not_Connected'Identity, 643 "PG05: Not connected (Open_DB_Trace)."); 644 end if; 645 646 if Mode = Trace_None then 647 pragma assert(C.Trace_Mode = Trace_None); 648 return; -- No trace required 649 end if; 650 651 declare 652 use CStr, System, Ada.Text_IO, Ada.Text_IO.C_Streams; 653 procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); 654 pragma Import(C,PQtrace,"PQtrace"); 655 656 C_Filename : char_array := To_C(Filename); 657 File_Mode : char_array := To_C("a"); 658 begin 659 C.Trace_File := fopen(C_Filename'Address,File_Mode'Address); 660 if C.Trace_File = Null_Stream then 661 Raise_Exception(Ada.IO_Exceptions.Name_Error'Identity, 662 "PG06: Unable to open trace file " & Filename & " (Open_DB_Trace)."); 663 end if; 664 665 Open(C.Trace_Ada,Append_File,C.Trace_File,Form => "shared=yes"); 666 Ada.Text_IO.Put_Line(C.Trace_Ada,"-- Start of Trace, Mode = " & Trace_Mode_Type'Image(Mode)); 667 668 if Mode = Trace_DB or Mode = Trace_Full then 669 PQtrace(C.Connection,C.Trace_File); 670 end if; 671 672 end; 673 674 C.Trace_Filename := new String(1..Filename'Length); 675 C.Trace_Filename.all := Filename; 676 C.Trace_Mode := Mode; 677 C.Trace_On := True; -- Enabled by default until Set_Trace disables this 678 679 end Open_DB_Trace; 680 681 682 683 procedure Close_DB_Trace(C : in out Connection_Type) is 684 begin 685 686 if C.Trace_Mode = Trace_None then 687 return; -- No tracing in progress 688 end if; 689 690 pragma assert(C.Trace_Filename /= null); 691 692 declare 693 use CStr; 694 procedure PQuntrace(PGconn : PG_Conn); 695 pragma Import(C,PQuntrace,"PQuntrace"); 696 begin 697 if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then 698 PQuntrace(C.Connection); 699 end if; 700 701 Free(C.Trace_Filename); 702 703 Ada.Text_IO.Put_Line(C.Trace_Ada,"-- End of Trace."); 704 Ada.Text_IO.Close(C.Trace_Ada); -- This closes C.Trace_File too 705 706 C.Trace_Mode := Trace_None; 707 C.Trace_On := True; -- Restore default 708 end; 709 710 end Close_DB_Trace; 711 712 713 714 procedure Set_Trace(C : in out Connection_Type; Trace_On : Boolean := True) is 715 procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); 716 procedure PQuntrace(PGconn : PG_Conn); 717 pragma Import(C,PQtrace,"PQtrace"); 718 pragma Import(C,PQuntrace,"PQuntrace"); 719 720 Orig_Trace : Boolean := C.Trace_On; 721 begin 722 C.Trace_On := Set_Trace.Trace_On; 723 724 if Orig_Trace = C.Trace_On then 725 return; -- No change 726 end if; 727 728 if C.Trace_On then 729 if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then 730 PQtrace(C.Connection,C.Trace_File); -- Enable libpq tracing 731 end if; 732 else 733 if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then 734 PQuntrace(C.Connection); -- Disable libpq tracing 735 end if; 736 end if; 737 end Set_Trace; 738 739 740 741 function Is_Trace(C : Connection_Type) return Boolean is 742 begin 743 return C.Trace_On; 744 end Is_Trace; 745 746 747 748 function In_Abort_State(C : Connection_Type) return Boolean is 749 begin 750 if C.Connection = Null_Connection then 751 return False; 752 end if; 753 return C.Abort_State; 754 end In_Abort_State; 755 756 757 758 ------------------------------ 759 -- SQL QUERY API : 760 ------------------------------ 761 762 763 procedure Free(R : in out PQ_Result) is 764 procedure PQclear(R : PQ_Result); 765 pragma Import(C,PQclear,"PQclear"); 766 begin 767 if R /= Null_Result then 768 PQclear(R); 769 R := Null_Result; 770 end if; 771 end Free; 772 773 774 775 procedure Clear(Q : in out Query_Type) is 776 begin 777 Free(Q.Result); 778 Clear(Root_Query_Type(Q)); 779 end Clear; 780 781 782 783 procedure Append_Quoted(Q : in out Query_Type; Connection : Root_Connection_Type'Class; SQL : String; After : String := "") is 784 function PQescapeString(to, from : System.Address; length : size_t) return size_t; 785 pragma Import(C,PQescapeString,"PQescapeString"); 786 C_Length : size_t := SQL'Length * 2 + 1; 787 C_From : char_array := To_C(SQL); 788 C_To : char_array(0..C_Length-1); 789 R_Length : size_t := PQescapeString(C_To'Address,C_From'Address,C_Length); 790 begin 791 Append(Q,"'" & To_Ada(C_To) & "'",After); 792 Q.Caseless(Q.Count) := False; -- Preserve case for this one 793 end Append_Quoted; 794 795 796 797 procedure Execute(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is 798 function PQexec(C : PG_Conn; Q : System.Address) return PQ_Result; 799 pragma Import(C,PQexec,"PQexec"); 800 R : Result_Type; 801 begin 802 803 Query.SQL_Case := Connection.SQL_Case; 804 805 if not Is_Connected(Connection) then 806 Raise_Exception(Not_Connected'Identity, 807 "PG14: The Connection_Type object supplied is not connected (Execute)."); 808 end if; 809 810 if In_Abort_State(Connection) then 811 Raise_Exception(Abort_State'Identity, 812 "PG15: The PostgreSQL connection is in the Abort state (Execute)."); 813 end if; 814 815 if Query.Result /= Null_Result then 816 Free(Query.Result); 817 end if; 818 819 declare 820 A_Query : String := To_String(Query); 821 C_Query : char_array := To_C(A_Query); 822 begin 823 if Connection.Trace_On then 824 if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then 825 Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- SQL QUERY:"); 826 Ada.Text_IO.Put_Line(Connection.Trace_Ada,A_Query); 827 Ada.Text_IO.Put_Line(Connection.Trace_Ada,";"); 828 end if; 829 end if; 830 831 Query.Result := PQexec(Internal_Connection(Connection_Type(Connection)),C_Query'Address); 832 833 if Connection.Trace_On then 834 if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then 835 Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Result: '" & Command_Status(Query) & "'"); 836 Ada.Text_IO.New_Line(Connection.Trace_Ada); 837 end if; 838 end if; 839 end; 840 841 if Query.Result /= Null_Result then 842 Query.Tuple_Index := First_Tuple_Index; 843 R := Result(Query); 844 if R /= Command_OK and R /= Tuples_OK then 845-- if Connection.Trace_On then 846-- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & 847-- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); 848-- end if; 849 Raise_Exception(SQL_Error'Identity, 850 "PG16: The query failed (Execute)."); 851 end if; 852 else 853-- if Connection.Trace_On then 854-- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & 855-- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); 856-- end if; 857 Raise_Exception(SQL_Error'Identity, 858 "PG17: The query failed (Execute)."); 859 end if; 860 861 end Execute; 862 863 864 865 procedure Execute_Checked(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class; Msg : String := "") is 866 use Ada.Text_IO; 867 begin 868 begin 869 Execute(Query,Connection); 870 exception 871 when Ex : SQL_Error => 872 if Msg'Length > 0 then 873 Put(Standard_Error,"*** SQL ERROR: "); 874 Put_Line(Standard_Error,Msg); 875 else 876 Put(Standard_Error,"*** SQL ERROR IN QUERY:"); 877 New_Line(Standard_Error); 878 Put(Standard_Error,To_String(Query)); 879 if Col(Standard_Error) > 1 then 880 New_Line(Standard_Error); 881 end if; 882 end if; 883 Put(Standard_Error,"["); 884 Put(Standard_Error,Result_Type'Image(Result(Query))); 885 Put(Standard_Error,": "); 886 Put(Standard_Error,Error_Message(Query)); 887 Put_Line(Standard_Error,"]"); 888 Reraise_Occurrence(Ex); 889 when Ex : others => 890 Reraise_Occurrence(Ex); 891 end; 892 end Execute_Checked; 893 894 895 896 procedure Begin_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is 897 begin 898 if In_Abort_State(Connection) then 899 Raise_Exception(Abort_State'Identity, 900 "PG36: PostgreSQL connection is in the abort state (Begin_Work)."); 901 end if; 902 Clear(Query); 903 Prepare(Query,"BEGIN WORK"); 904 Execute(Query,Connection); 905 Clear(Query); 906 end Begin_Work; 907 908 909 910 procedure Commit_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is 911 begin 912 if In_Abort_State(Connection) then 913 Raise_Exception(Abort_State'Identity, 914 "PG37: PostgreSQL connection is in the abort state (Commit_Work)."); 915 end if; 916 Clear(Query); 917 Prepare(Query,"COMMIT WORK"); 918 Execute(Query,Connection); 919 Clear(Query); 920 end Commit_Work; 921 922 923 924 procedure Rollback_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is 925 begin 926 Clear(Query); 927 Prepare(Query,"ROLLBACK WORK"); 928 Execute(Query,Connection); 929 Clear_Abort_State(Connection); 930 Clear(Query); 931 end Rollback_Work; 932 933 934 935 procedure Rewind(Q : in out Query_Type) is 936 begin 937 Q.Rewound := True; 938 Q.Tuple_Index := First_Tuple_Index; 939 end Rewind; 940 941 942 943 procedure Fetch(Q : in out Query_Type) is 944 begin 945 if not Q.Rewound then 946 Q.Tuple_Index := Q.Tuple_Index + 1; 947 else 948 Q.Rewound := False; 949 end if; 950 Fetch(Q,Q.Tuple_Index); 951 end Fetch; 952 953 954 955 procedure Fetch(Q : in out Query_Type; TX : Tuple_Index_Type) is 956 NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result 957 begin 958 if NT < 1 then 959 Raise_Exception(No_Tuple'Identity, 960 "PG33: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); 961 end if; 962 Q.Tuple_Index := TX; 963 Q.Rewound := False; 964 if TX > NT then 965 Raise_Exception(No_Tuple'Identity, 966 "PG34: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); 967 end if; 968 end Fetch; 969 970 971 972 function End_of_Query(Q : Query_Type) return Boolean is 973 NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result 974 begin 975 if NT < 1 then 976 return True; -- There are no tuples to return 977 end if; 978 979 if Q.Rewound then 980 return False; -- There is at least 1 tuple to return yet 981 end if; 982 983 return Tuple_Count_Type(Q.Tuple_Index) >= NT; -- We've fetched them all 984 end End_of_Query; 985 986 987 988 function Tuple(Q : Query_Type) return Tuple_Index_Type is 989 NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result 990 begin 991 if NT < 1 or else Q.Rewound then 992 Raise_Exception(No_Tuple'Identity, 993 "PG35: There are no tuples to return (Tuple)."); 994 end if; 995 return Q.Tuple_Index; 996 end Tuple; 997 998 999 1000 function Tuples(Q : Query_Type) return Tuple_Count_Type is 1001 use Interfaces.C; 1002 function PQntuples(R : PQ_Result) return int; 1003 pragma Import(C,PQntuples,"PQntuples"); 1004 begin 1005 if Q.Result = Null_Result then 1006 Raise_Exception(No_Result'Identity, 1007 "PG19: There are no query results (Tuples)."); 1008 end if; 1009 return Tuple_Count_Type(PQntuples(Q.Result)); 1010 end Tuples; 1011 1012 1013 1014 function Columns(Q : Query_Type) return Natural is 1015 use Interfaces.C; 1016 function PQnfields(R : PQ_Result) return int; 1017 pragma Import(C,PQnfields,"PQnfields"); 1018 begin 1019 if Q.Result = Null_Result then 1020 Raise_Exception(No_Result'Identity, 1021 "PG20: There are no query results (Columns)."); 1022 end if; 1023 return Natural(PQnfields(Q.Result)); 1024 end Columns; 1025 1026 1027 1028 function Column_Name(Q : Query_Type; CX : Column_Index_Type) return String is 1029 use Interfaces.C.Strings; 1030 function PQfname(R : PQ_Result; CBX : int) return chars_ptr; 1031 pragma Import(C,PQfname,"PQfname"); 1032 1033 CBX : int := int(CX) - 1; -- Make zero based 1034 begin 1035 if Q.Result = Null_Result then 1036 Raise_Exception(No_Result'Identity, 1037 "PG21: There are no query results (Column_Name)."); 1038 end if; 1039 declare 1040 use Interfaces.C.Strings; 1041 CP : chars_ptr := PQfname(Q.Result,CBX); 1042 begin 1043 if CP = Null_Ptr then 1044 Raise_Exception(No_Column'Identity, 1045 "PG22: There is no column CX=" & Column_Index_Type'Image(CX) & "."); 1046 end if; 1047 return To_Case(Value_Of(CP),Q.SQL_Case); 1048 end; 1049 end Column_Name; 1050 1051 1052 1053 function Column_Index(Q : Query_Type; Name : String) return Column_Index_Type is 1054 use Interfaces.C.Strings; 1055 function PQfnumber(R : PQ_Result; CBX : System.Address) return int; 1056 pragma Import(C,PQfnumber,"PQfnumber"); 1057 1058 C_Name : char_array := To_C(Name); 1059 CBX : int := -1; 1060 begin 1061 if Q.Result = Null_Result then 1062 Raise_Exception(No_Result'Identity, 1063 "PG23: There are no query results (Column_Index)."); 1064 end if; 1065 CBX := PQfnumber(Q.Result,C_Name'Address); 1066 if CBX < 0 then 1067 Raise_Exception(No_Column'Identity, 1068 "PG24: There is no column named '" & Name & " (Column_Index)."); 1069 end if; 1070 return Column_Index_Type(CBX+1); 1071 end Column_Index; 1072 1073 1074 1075 function Is_Column(Q : Query_Type; CX : Column_Index_Type) return Boolean is 1076 begin 1077 if Q.Result = Null_Result then 1078 return False; 1079 end if; 1080 return Natural(CX) <= Columns(Q); 1081 end Is_Column; 1082 1083 1084 1085 function Column_Type(Q : Query_Type; CX : Column_Index_Type) return Row_ID_Type is 1086 function PQftype(R : PQ_Result; Field_Index : int) return PQOid_Type; 1087 pragma Import(C,PQftype,"PQftype"); 1088 CBX : int := int(CX) - 1; 1089 begin 1090 if Q.Result = Null_Result then 1091 Raise_Exception(No_Result'Identity, 1092 "PG25: There are no query results (Column_Type)."); 1093 end if; 1094 if not Is_Column(Q,CX) then 1095 Raise_Exception(No_Column'Identity, 1096 "PG26: There is no column CX=" & Column_Index_Type'Image(CX) & " (Column_Type)."); 1097 end if; 1098 return Row_ID_Type(PQftype(Q.Result,CBX)); 1099 end Column_Type; 1100 1101 1102 1103 function Is_Null(Q : Query_Type; CX : Column_Index_Type) return Boolean is 1104 use Interfaces.C.Strings; 1105 function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; 1106 pragma Import(C,PQgetisnull,"PQgetisnull"); 1107 C_TX : int := int(Q.Tuple_Index) - 1; -- Make zero based tuple # 1108 C_CX : int := int(CX) - 1; -- Field index 1109 begin 1110 if Q.Result = Null_Result then 1111 Raise_Exception(No_Result'Identity, 1112 "PG31: There are no query results (Is_Null)."); 1113 end if; 1114 if not Is_Column(Q,CX) then 1115 Raise_Exception(No_Column'Identity, 1116 "PG32: There is now column" & Column_Index_Type'Image(CX) & " (Is_Null)."); 1117 end if; 1118 return PQgetisnull(Q.Result,C_TX,C_CX) /= 0; 1119 end Is_Null; 1120 1121 1122 1123 function Value(Query : Query_Type; CX : Column_Index_Type) return String is 1124 use Interfaces.C.Strings; 1125 function PQgetvalue(R : PQ_Result; tup_num, field_num : int) return chars_ptr; 1126 pragma Import(C,PQgetvalue,"PQgetvalue"); 1127 function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; 1128 pragma Import(C,PQgetisnull,"PQgetisnull"); 1129 C_TX : int := int(Query.Tuple_Index) - 1; -- Make zero based tuple # 1130 C_CX : int := int(CX) - 1; -- Field index 1131 begin 1132 if Query.Result = Null_Result then 1133 Raise_Exception(No_Result'Identity, 1134 "PG27: There are no query results (Value)."); 1135 end if; 1136 if not Is_Column(Query,CX) then 1137 Raise_Exception(No_Column'Identity, 1138 "PG28: There is no column CX=" & Column_Index_Type'Image(CX) & " (Value)."); 1139 end if; 1140 declare 1141 use Ada.Strings, Ada.Strings.Fixed; 1142 1143 C_Val : chars_ptr := PQgetvalue(Query.Result,C_TX,C_CX); 1144 begin 1145 if C_Val = Null_Ptr then 1146 Raise_Exception(No_Tuple'Identity, 1147 "PG29: There is no row" & Tuple_Index_Type'Image(Query.Tuple_Index) & " (Value)."); 1148 elsif PQgetisnull(Query.Result,C_TX,C_CX) /= 0 then 1149 Raise_Exception(Null_Value'Identity, 1150 "PG30: Value for column" & Column_Index_Type'Image(CX) & " is NULL (Value)."); 1151 else 1152 return Trim(Value_Of(C_Val),Right); 1153 end if; 1154 end; 1155 1156 end Value; 1157 1158 1159 1160 function Result(Query : Query_Type) return Natural is 1161 begin 1162 return Result_Type'Pos(Result(Query)); 1163 end Result; 1164 1165 1166 1167 function Result(Query : Query_Type) return Result_Type is 1168 function PQresultStatus(R : PQ_Result) return Result_Type; 1169 pragma Import(C,PQresultStatus,"PQresultStatus"); 1170 begin 1171 if Query.Result = Null_Result then 1172 Raise_Exception(No_Result'Identity, 1173 "PG13: There are no query results (function Result)."); 1174 end if; 1175 return PQresultStatus(Query.Result); 1176 end Result; 1177 1178 1179 1180 function Command_Oid(Query : Query_Type) return Row_ID_Type is 1181 function PQoidValue(R : PQ_Result) return PQOid_Type; 1182 pragma Import(C,PQoidValue,"PQoidValue"); 1183 begin 1184 1185 if Query.Result = Null_Result then 1186 Raise_Exception(No_Result'Identity, 1187 "PG12: There are no query results (Command_Oid)."); 1188 end if; 1189 1190 return Row_ID_Type(PQoidValue(Query.Result)); 1191 end Command_Oid; 1192 1193 1194 1195 function Null_Oid(Query : Query_Type) return Row_ID_Type is 1196 begin 1197 return APQ.PostgreSQL.Null_Row_ID; 1198 end Null_Oid; 1199 1200 1201 1202 function Command_Status(Query : Query_Type) return String is 1203 use Interfaces.C.Strings; 1204 function PQcmdStatus(R : PQ_Result) return chars_ptr; 1205 pragma Import(C,PQcmdStatus,"PQcmdStatus"); 1206 begin 1207 1208 if Query.Result = Null_Result then 1209 Raise_Exception(No_Result'Identity, 1210 "PG11: There are no query results (Command_Status)."); 1211 end if; 1212 1213 declare 1214 use Interfaces.C.Strings; 1215 Msg_Ptr : chars_ptr := PQcmdStatus(Query.Result); 1216 begin 1217 if Msg_Ptr = Null_Ptr then 1218 return ""; 1219 else 1220 return Strip_NL(Value_Of(Msg_Ptr)); 1221 end if; 1222 end; 1223 end Command_Status; 1224 1225 1226 1227 1228 function Error_Message(Query : Query_Type) return String is 1229 use Interfaces.C.Strings; 1230 function PQresultErrorMessage(R : PQ_Result) return chars_ptr; 1231 pragma Import(C,PQresultErrorMessage,"PQresultErrorMessage"); 1232 begin 1233 if Query.Result = Null_Result then 1234 Raise_Exception(No_Result'Identity, 1235 "PG10: There are no query results (Error_Message)."); 1236 end if; 1237 1238 declare 1239 use Interfaces.C.Strings; 1240 Msg_Ptr : chars_ptr := PQresultErrorMessage(Query.Result); 1241 begin 1242 if Msg_Ptr = Null_Ptr then 1243 return ""; 1244 else 1245 return Strip_NL(Value_Of(Msg_Ptr)); 1246 end if; 1247 end; 1248 end Error_Message; 1249 1250 1251 1252 function Is_Duplicate_Key(Query : Query_Type) return Boolean is 1253 Msg : String := Error_Message(Query); 1254 Dup : constant String := "ERROR: Cannot insert a duplicate key"; 1255 begin 1256 if Msg'Length < Dup'Length then 1257 return False; 1258 end if; 1259 return Msg(Msg'First..Msg'First+Dup'Length-1) = Dup; 1260 end Is_Duplicate_Key; 1261 1262 1263 1264 function Engine_Of(Q : Query_Type) return Database_Type is 1265 begin 1266 return Engine_PostgreSQL; 1267 end Engine_Of; 1268 1269 1270 -------------------------------------------------- 1271 -- BLOB SUPPORT : 1272 -------------------------------------------------- 1273 1274 function lo_creat(conn : PG_Conn; Mode : Mode_Type) return PQOid_Type; 1275 pragma Import(C,lo_creat,"lo_creat"); 1276 1277 function lo_open(conn : PG_Conn; Oid : PQOid_Type; Mode : Mode_Type) return Blob_Fd; 1278 pragma Import(C,lo_open,"lo_open"); 1279 1280 function lo_close(conn : PG_Conn; fd : Blob_Fd) return int; 1281 pragma Import(C,lo_close,"lo_close"); 1282 1283 function lo_read(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; 1284 pragma Import(C,lo_read,"lo_read"); 1285 1286 function lo_write(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; 1287 pragma Import(C,lo_write,"lo_write"); 1288 1289 function lo_unlink(conn : PG_Conn; Oid : PQOid_Type) return int; 1290 pragma Import(C,lo_unlink,"lo_unlink"); 1291 1292 function lo_lseek(conn : PG_Conn; fd : Blob_Fd; offset, whence : int) return int; 1293 pragma Import(C,lo_lseek,"lo_lseek"); 1294 1295 procedure Free is new Ada.Unchecked_Deallocation(Blob_Object,Blob_Type); 1296 1297 1298 -- internal 1299 1300 function Raw_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is 1301 use Ada.Streams; 1302 Offset : int; 1303 begin 1304 loop -- In loop form in case EINTR processing should be required someday 1305 Offset := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_Cur); 1306 exit when Offset >= 0; 1307 Raise_Exception(Blob_Error'Identity, 1308 "PG38: Server blob error occurred."); 1309 end loop; 1310 1311 return Stream_Element_Offset(Offset + 1); 1312 end Raw_Index; 1313 1314 1315 1316 1317 procedure Raw_Set_Index(Blob : Blob_Object; To : Str.Stream_Element_Offset) is 1318 Offset : int := int(To) - 1; 1319 Z : int; 1320 begin 1321 loop -- In loop form in case EINTR processing should be required someday 1322 Z := lo_lseek(Blob.Conn.Connection,Blob.Fd,Offset,Seek_Set); 1323 exit when Z >= 0; 1324 Raise_Exception(Blob_Error'Identity, 1325 "PG39: Server blob error occurred."); 1326 end loop; 1327 end Raw_Set_Index; 1328 1329 1330 1331 function Internal_Size(Blob : Blob_Type) return Str.Stream_Element_Offset is 1332 use Ada.Streams; 1333 Saved_Pos : Stream_Element_Offset := Raw_Index(Blob); 1334 End_Offset : int := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_End); 1335 begin 1336 if End_Offset < 0 then 1337 Raise_Exception(Blob_Error'Identity, 1338 "PG40: Server blob error occurred."); 1339 end if; 1340 Raw_Set_Index(Blob.all,Saved_Pos); 1341 return Stream_Element_Offset(End_Offset); 1342 end Internal_Size; 1343 1344 1345 1346 procedure Internal_Write( 1347 Stream: in out Blob_Object; 1348 Item: in Ada.Streams.Stream_Element_Array 1349 ) is 1350 use Ada.Streams; 1351 Total : size_t := 0; 1352 Len : size_t; 1353 IX : Stream_Element_Offset := Item'First; 1354 N : int; 1355 begin 1356 while IX < Item'Last loop 1357 Len := size_t(Item'Last - IX + 1); 1358 N := lo_write(Stream.Conn.Connection,Stream.Fd,Item(IX)'Address,Len); 1359 if N < 0 then 1360 Raise_Exception(Blob_Error'Identity, 1361 "PG43: Server blob write error occurred."); 1362 elsif N > 0 then 1363 IX := IX + Stream_Element_Offset(N); 1364 1365 Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); 1366 if Stream.Phy_Offset - 1 > Stream.The_Size then 1367 Stream.The_Size := Stream.Phy_Offset - 1; 1368 end if; 1369 end if; 1370 1371 if N = 0 then 1372 Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, 1373 "PG44: End_Error raised while server was writing blob."); 1374 end if; 1375 end loop; 1376 1377 end Internal_Write; 1378 1379 1380 1381 procedure Internal_Read( 1382 Stream: in out Blob_Object; 1383 Item: out Ada.Streams.Stream_Element_Array; 1384 Last: out Ada.Streams.Stream_Element_Offset 1385 ) is 1386 use Ada.Streams; 1387 1388 Len : size_t := size_t(Item'Length); 1389 N : int; 1390 begin 1391 1392 loop -- In loop form in case EINTR processing should be required someday 1393 N := lo_read(Stream.Conn.Connection,Stream.Fd,Item(Item'First)'Address,Len); 1394 exit when N >= 0; 1395 Raise_Exception(Blob_Error'Identity, 1396 "PG41: Server blob error occurred while reading the blob."); 1397 end loop; 1398 1399 if N = 0 then 1400 Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, 1401 "PG42: Reached the end of blob while reading."); 1402 end if; 1403 1404 Last := Item'First + Stream_Element_Offset(N) - 1; 1405 Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); 1406 1407 end Internal_Read; 1408 1409 1410 1411 procedure Internal_Blob_Open(Blob : in out Blob_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) is 1412 use Ada.Streams; 1413 begin 1414 Blob.Mode := Internal_Blob_Open.Mode; 1415 Blob.Fd := lo_open(Blob.Conn.Connection,PQOid_Type(Blob.Oid),Blob.Mode); 1416 if Blob.Fd = -1 then 1417 Free(Blob); 1418 Raise_Exception(Blob_Error'Identity, 1419 "PG45: Unable to open blob on server (OID=" & Row_ID_Type'Image(Blob.Oid) & ")."); 1420 end if; 1421 if Buf_Size > 0 then 1422 Blob.Buffer := new Stream_Element_Array(1..Stream_Element_Offset(Buf_Size)); 1423 Blob.Buf_Empty := True; 1424 Blob.Buf_Dirty := False; 1425 Blob.Buf_Offset := 0; 1426 Blob.Log_Offset := 1; 1427 Blob.Phy_Offset := 1; 1428 Blob.The_Size := Stream_Element_Offset(Internal_Size(Blob)); 1429 else 1430 null; -- unbuffered blob operations will be used 1431 end if; 1432 end Internal_Blob_Open; 1433 1434 1435 1436 procedure Internal_Set_Index(Blob : in out Blob_Object; To : Str.Stream_Element_Offset) is 1437 use Ada.Streams; 1438 begin 1439 if Blob.Phy_Offset /= Stream_Element_Offset(To) then 1440 Raw_Set_Index(Blob,To); 1441 Blob.Phy_Offset := Stream_Element_Offset(To); 1442 end if; 1443 end Internal_Set_Index; 1444 1445 1446 1447 -- end internal 1448 1449 1450 1451 function Blob_Create(DB : access Connection_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is 1452 Blob : Blob_Type; 1453 begin 1454 Blob := new Blob_Object(DB); 1455 Blob.Oid := Row_ID_Type(lo_creat(Blob.Conn.Connection,Read_Write)); 1456 if Blob.Oid = -1 then 1457 free(Blob); 1458 Raise_Exception(Blob_Error'Identity, 1459 "PG46: Unable to create blob on server."); 1460 end if; 1461 1462 begin 1463 Internal_Blob_Open(Blob,Write,Buf_Size); 1464 exception 1465 when Ex : others => 1466 Blob_Unlink(DB.all,Blob.Oid); -- Release what will result in an unused blob! 1467 Reraise_Occurrence(Ex); -- HINT: Internal_Blob_Open() FAILS IF IT IS NOT IN A TRANSACTION! 1468 end; 1469 1470 return Blob; 1471 end Blob_Create; 1472 1473 1474 1475 function Blob_Open(DB : access Connection_Type; Oid : Row_ID_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is 1476 Blob : Blob_Type; 1477 begin 1478 Blob := new Blob_Object(DB); 1479 Blob.Oid := Blob_Open.Oid; 1480 Internal_Blob_Open(Blob,Mode,Buf_Size); 1481 return Blob; 1482 end Blob_Open; 1483 1484 1485 1486 procedure Blob_Flush(Blob : in out Blob_Object) is 1487 begin 1488 if Blob.Buffer /= null then 1489 if ( not Blob.Buf_Empty ) and Blob.Buf_Dirty then 1490 Internal_Set_Index(Blob,Blob.Buf_Offset); 1491 Internal_Write(Blob,Blob.Buffer(1..Blob.Buf_Size)); 1492 end if; 1493 Blob.Buf_Dirty := False; 1494 else 1495 null; -- Ignore flush calls in the unbuffered case 1496 end if; 1497 end Blob_Flush; 1498 1499 1500 1501 procedure Blob_Flush(Blob : Blob_Type) is 1502 begin 1503 Blob_Flush(Blob.all); 1504 end Blob_Flush; 1505 1506 1507 1508 procedure Internal_Blob_Close(Blob : in out Blob_Object) is 1509 Z : int; 1510 begin 1511 if Blob.Buffer /= null then 1512 if Blob.Buf_Dirty then 1513 Blob_Flush(Blob); 1514 end if; 1515 Free(Blob.Buffer); 1516 end if; 1517 1518 Z := lo_close(Blob.Conn.Connection,Blob.Fd); 1519 if Z /= 0 then 1520 Raise_Exception(Blob_Error'Identity, 1521 "PG47: Server error when closing blob."); 1522 end if; 1523 Blob.Fd := -1; 1524 end Internal_Blob_Close; 1525 1526 1527 1528 procedure Blob_Close(Blob : in out Blob_Type) is 1529 begin 1530 Internal_Blob_Close(Blob.all); 1531 Free(Blob); 1532 end Blob_Close; 1533 1534 1535 1536 procedure Blob_Set_Index(Blob : Blob_Type; To : Blob_Offset) is 1537 use Ada.Streams; 1538 begin 1539 if Blob.Buffer /= null then 1540 Blob.Log_Offset := Stream_Element_Offset(To); 1541 else 1542 Internal_Set_Index(Blob.all,Stream_Element_Offset(To)); 1543 end if; 1544 end Blob_Set_Index; 1545 1546 1547 1548 function Internal_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is 1549 begin 1550 return Blob.Phy_Offset; 1551 end Internal_Index; 1552 1553 1554 1555 function Blob_Index(Blob : Blob_Type) return Blob_Offset is 1556 begin 1557 if Blob.Buffer /= null then 1558 return Blob_Offset(Blob.Log_Offset); 1559 else 1560 return Blob_Offset(Internal_Index(Blob)); 1561 end if; 1562 end Blob_Index; 1563 1564 1565 1566 function End_of_Blob(Blob : Blob_Type) return Boolean is 1567 use Ada.Streams; 1568 begin 1569 if Blob.Buffer /= null then 1570 return Blob.Log_Offset > Blob.The_Size; 1571 else 1572 return Blob_Index(Blob) > Blob_Size(Blob); 1573 end if; 1574 end End_of_Blob; 1575 1576 1577 1578 function Blob_Oid(Blob : Blob_Type) return Row_ID_Type is 1579 begin 1580 return Blob.Oid; 1581 end Blob_Oid; 1582 1583 1584 1585 function Blob_Size(Blob : Blob_Type) return Blob_Count is 1586 begin 1587 if Blob.Buffer /= null then 1588 return Blob_Count(Blob.The_Size); 1589 else 1590 return Blob_Count(Internal_Size(Blob)); 1591 end if; 1592 end Blob_Size; 1593 1594 1595 1596 function Blob_Stream(Blob : Blob_Type) return Root_Stream_Access is 1597 begin 1598 if Blob = Null then 1599 Raise_Exception(Blob_Error'Identity, 1600 "PG49: No blob to create a stream from (Blob_Stream)."); 1601 end if; 1602 return Root_Stream_Access(Blob); 1603 end Blob_Stream; 1604 1605 1606 1607 procedure Blob_Unlink(DB : Connection_Type; Oid : Row_ID_Type) is 1608 Z : int; 1609 begin 1610 Z := lo_unlink(DB.Connection,PQOid_Type(Oid)); 1611 if Z = -1 then 1612 Raise_Exception(Blob_Error'Identity, 1613 "PG50: Unable to unlink blob OID=" & Row_ID_Type'Image(Oid) & " (Blob_Unlink)."); 1614 end if; 1615 end Blob_Unlink; 1616 1617 1618 1619 function lo_import(conn : PG_Conn; filename : System.Address) return int; 1620 pragma Import(C,lo_import,"lo_import"); 1621 1622 function lo_export(conn : PG_Conn; Oid : PQOid_Type; filename : System.Address) return int; 1623 pragma Import(C,lo_export,"lo_export"); 1624 1625 1626 procedure Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Row_ID_Type) is 1627 use Interfaces.C; 1628 P : char_array := To_C(Pathname); 1629 Z : int; 1630 begin 1631 Oid := Row_ID_Type'Last; 1632 Z := lo_import(DB.Connection,P'Address); 1633 if Z <= -1 then 1634 Raise_Exception(Blob_Error'Identity, 1635 "PG51: Unable to import blob from " & Pathname & " (Blob_Import)."); 1636 end if; 1637 Oid := Row_ID_Type(Z); 1638 end Blob_Import; 1639 1640 1641 1642 procedure Blob_Export(DB : Connection_Type; Oid : Row_ID_Type; Pathname : String) is 1643 P : char_array := To_C(Pathname); 1644 Z : int; 1645 begin 1646 Z := lo_export(DB.Connection,PQOid_Type(Oid),P'Address); 1647 if Z <= -1 then 1648 Raise_Exception(Blob_Error'Identity, 1649 "PG52: Unable to export blob to " & Pathname & " (Blob_Export)."); 1650 end if; 1651 end Blob_Export; 1652 1653 1654 1655 function Generic_Blob_Open(DB : access Connection_Type; Oid : Oid_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is 1656 begin 1657 return Blob_Open(DB,Row_ID_Type(Oid),Mode,Buf_Size); 1658 end Generic_Blob_Open; 1659 1660 1661 1662 function Generic_Blob_Oid(Blob : Blob_Type) return Oid_Type is 1663 begin 1664 return Oid_Type(Blob_Oid(Blob)); 1665 end Generic_Blob_Oid; 1666 1667 1668 1669 procedure Generic_Blob_Unlink(DB : Connection_Type; Oid : Oid_Type) is 1670 begin 1671 Blob_Unlink(DB,Row_ID_Type(Oid)); 1672 end Generic_Blob_Unlink; 1673 1674 1675 1676 procedure Generic_Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Oid_Type) is 1677 Local_Oid : Row_ID_Type; 1678 begin 1679 Blob_Import(DB,Pathname,Local_Oid); 1680 Oid := Oid_Type(Local_Oid); 1681 end Generic_Blob_Import; 1682 1683 1684 1685 procedure Generic_Blob_Export(DB : Connection_Type; Oid : Oid_Type; Pathname : String) is 1686 begin 1687 Blob_Export(DB,Row_ID_Type(Oid),Pathname); 1688 end Generic_Blob_Export; 1689 1690 1691 1692-- private 1693 1694 1695 --------------------- 1696 -- CONNECTION_TYPE -- 1697 --------------------- 1698 1699 1700 procedure Initialize(C : in out Connection_Type) is 1701 begin 1702 C.Port_Format := IP_Port; 1703 C.Port_Number := 5432; 1704 end Initialize; 1705 1706 1707 1708 procedure Finalize(C : in out Connection_Type) is 1709 begin 1710 Internal_Reset(C,In_Finalize => True); 1711 end Finalize; 1712 1713 1714 1715 function Internal_Connection(C : Connection_Type) return PG_Conn is 1716 begin 1717 return C.Connection; 1718 end Internal_Connection; 1719 1720 1721 1722 function Query_Factory( C: in Connection_Type ) return Root_Query_Type'Class is 1723 q: Query_Type; 1724 begin 1725 return q; 1726 end query_factory; 1727 1728 1729 1730 ---------------- 1731 -- QUERY_TYPE -- 1732 ---------------- 1733 1734 1735 procedure Adjust(Q : in out Query_Type) is 1736 begin 1737 Q.Result := Null_Result; 1738 Adjust(Root_Query_Type(Q)); 1739 end Adjust; 1740 1741 1742 1743 procedure Finalize(Q : in out Query_Type) is 1744 begin 1745 Clear(Q); 1746 end Finalize; 1747 1748 1749 1750 function SQL_Code(Query : Query_Type) return SQL_Code_Type is 1751 begin 1752 return 0; 1753 end SQL_Code; 1754 1755 1756 1757 --------------- 1758 -- BLOB_TYPE -- 1759 --------------- 1760 1761 1762 procedure Finalize(Blob : in out Blob_Object) is 1763 begin 1764 if Blob.Fd /= -1 then 1765 Internal_Blob_Close(Blob); 1766 end if; 1767 end Finalize; 1768 1769 1770 1771 procedure Read( 1772 Stream: in out Blob_Object; 1773 Item: out Ada.Streams.Stream_Element_Array; 1774 Last: out Ada.Streams.Stream_Element_Offset 1775 ) is 1776 use Ada.Streams; 1777 1778 IX : Stream_Element_Offset := Item'First; 1779 BX : Stream_Element_Offset; 1780 begin 1781 1782 if Stream.Buffer /= null then 1783 while IX <= Item'Last and Stream.Log_Offset <= Stream.The_Size loop 1784 1785 if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- if not empty and is dirty 1786 if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low 1787 or else Stream.Log_Offset >= Stream.Buf_Offset + Stream.Buf_Size then -- or offset too high 1788 Blob_Flush(Stream); 1789 Stream.Buf_Empty := True; 1790 end if; 1791 end if; 1792 1793 if Stream.Buf_Empty then -- If we have an empty buffer then.. 1794 if Stream.Log_Offset > Stream.The_Size + 1 then 1795 Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, 1796 "PG47: End reached while reading blob."); 1797 end if; 1798 1799 Stream.Buf_Offset := Stream.Log_Offset; -- Start with our convenient offset 1800 Stream.Buf_Size := Stream.Buffer.all'Length; -- Try to read entire buffer in 1801 if Stream.Buf_Offset + Stream.Buf_Size - 1 > Stream.The_Size then 1802 Stream.Buf_Size := Stream.The_Size + 1 - Stream.Buf_Offset; -- read somewhat less in 1803 end if; 1804 Internal_Set_Index(Stream,Stream.Buf_Offset); 1805 Internal_Read(Stream,Stream.Buffer(1..Stream.Buf_Size),Last); 1806 if Last /= Stream.Buf_Size then -- Check that all was read 1807 Raise_Exception(Blob_Error'Identity, 1808 "PG48: Error while reading from blob."); 1809 end if; 1810 Stream.Buf_Empty := False; -- Buffer is not empty 1811 pragma assert(Stream.Buf_Dirty = False); -- Should not be dirty at this point 1812 BX := Stream.Buffer.all'First; -- Start reading from buffer here 1813 else 1814 BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; 1815 end if; 1816 1817 Item(IX) := Stream.Buffer.all(BX); -- Read item byte 1818 IX := IX + 1; -- Advance item index 1819 Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance logical offset 1820 end loop; 1821 Last := IX - 1; 1822 else 1823 Internal_Read(Stream,Item,Last); 1824 end if; 1825 end Read; 1826 1827 1828 1829 procedure Write( 1830 Stream: in out Blob_Object; 1831 Item: in Ada.Streams.Stream_Element_Array 1832 ) is 1833 use Ada.Streams; 1834 1835 IX : Stream_Element_Offset := Item'First; 1836 BX : Stream_Element_Offset := -1; 1837 begin 1838 1839 if Stream.Buffer /= null then 1840 while IX <= Item'Last loop 1841 if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- Buffer is not empty and is dirty 1842 if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low 1843 or else Stream.Log_Offset > Stream.Buf_Offset + Stream.Buf_Size -- or offset too high 1844 or else Stream.Buf_Size >= Stream.Buffer.all'Length then -- or buffer is full then.. 1845 Blob_Flush(Stream); -- Flush out dirty data 1846 Stream.Buf_Empty := True; -- Now mark buffer as empty 1847 else 1848 BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; 1849 end if; 1850 else 1851 BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; 1852 end if; 1853 1854 if Stream.Buf_Empty then -- if buf was empty or was just made empty then.. 1855 Stream.Buf_Offset := Stream.Log_Offset; -- Set to our convenient offset 1856 Stream.Buf_Size := 0; -- No data in this buffer yet 1857 Stream.Buf_Dirty := False; -- Make sure it's not marked dirty yet 1858 BX := Stream.Buffer.all'First; -- Point to start of buffer 1859 end if; 1860 1861 Stream.Buffer.all(BX) := Item(IX); -- Write the byte 1862 IX := IX + 1; -- Advance Item Index 1863 Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance the logical blob offset 1864 Stream.Buf_Empty := False; -- Buffer is no longer empty 1865 Stream.Buf_Dirty := True; -- Buffer has been modified 1866 1867 if BX > Stream.Buf_Size then -- Did the buffer contents grow? 1868 Stream.Buf_Size := Stream.Buf_Size + 1; -- Buffer size has grown 1869 end if; 1870 end loop; 1871 else 1872 Internal_Write(Stream,Item); 1873 end if; 1874 end Write; 1875 1876 1877begin 1878 1879 declare 1880 use Ada.Calendar; 1881 begin 1882 No_Date := Time_Of(Year_Number'First,Month_Number'First,Day_Number'First); 1883 end; 1884 1885end APQ.PostgreSQL.Client; 1886 1887-- End $Source: /cvsroot/apq/apq/apq-postgresql-client.adb,v $ 1888