1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | with System.Address_To_Access_Conversions; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; with System; package body GNU.DB.PostgreSQL is pragma Linker_Options ("-lpq"); package C renames Interfaces.C; package CS renames Interfaces.C.Strings; subtype char_array is C.char_array; subtype chars_ptr is CS.chars_ptr; function To_Result is new Ada.Unchecked_Conversion (System.Address, PGresult); function To_Addr is new Ada.Unchecked_Conversion (PGresult, System.Address); function To_Conn is new Ada.Unchecked_Conversion (System.Address, Connection_Handle); function To_Addr is new Ada.Unchecked_Conversion (Connection_Handle, System.Address); protected body PGConn is function Handle return Connection_Handle is begin return C_Connection; end Handle; procedure Reset is procedure PQreset (Connection : System.Address); pragma Import (C, PQreset, "PQreset"); begin PQreset (To_Addr (C_Connection)); end Reset; function Error return String is function PQerr (Conn : System.Address) return chars_ptr; pragma Import (C, PQerr, "PQerrorMessage"); begin return CS.Value (PQerr (To_Addr (C_Connection))); end Error; function Status return ConnStatus is function PQstatus (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQstatus, "PQstatus"); begin return ConnStatus'Val (PQstatus (To_Addr (C_Connection))); end Status; procedure Close is procedure PQfinish (Connection : System.Address); pragma Import (C, PQfinish, "PQfinish"); begin if C_Connection /= Null_Connection then PQfinish (To_Addr (C_Connection)); C_Connection := Null_Connection; end if; end Close; function PID return Backend_PID is function PQpid (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQpid, "PQbackendPID"); function To_PID is new Ada.Unchecked_Conversion (Source => Interfaces.C.int, Target => Backend_PID); begin return To_PID (PQpid (To_Addr (C_Connection))); end PID; procedure Execute (Res : out Result; Query : in String) is function PQexec (Conn : System.Address; Qry : chars_ptr) return System.Address; pragma Import (C, PQexec, "PQexec"); P : chars_ptr := CS.New_String (Query); R : constant PGresult := To_Result (PQexec (To_Addr (C_Connection), P)); Stat : ExecStatus; begin CS.Free (P); if R = Null_Result then raise PostgreSQL_Error; else Res.Res := R; Stat := Status (Res); if Stat = PGRES_FATAL_ERROR then raise PostgreSQL_Error; end if; end if; end Execute; procedure Empty_Result (Res : out Result; Status : in ExecStatus) is function PQemptyRes (Conn : System.Address; Status : C.int) return System.Address; pragma Import (C, PQemptyRes, "PQmakeEmptyPGresult"); R : constant PGresult := To_Result (PQemptyRes (To_Addr (C_Connection), ExecStatus'Pos (Status))); begin if R = Null_Result then raise PostgreSQL_Error; else Res.Res := R; end if; end Empty_Result; procedure SetNonBlocking is function PQnonblocking (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQnonblocking, "PQsetnonblocking"); R : constant Interfaces.C.Int := PQnonblocking (To_Addr (C_Connection)); begin null; end SetNonBlocking; function IsNonBlocking return Boolean is function PQisnonblocking (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQisnonblocking, "PQisnonblocking"); R : constant Interfaces.C.Int := PQisnonblocking (To_Addr (C_Connection)); begin if R /= 0 then return True; else return False; end if; end IsNonBlocking; function SendQuery (Query : in String) return boolean is function PQsendQuery (Conn : System.Address; Qry : chars_ptr) return Interfaces.C.int; pragma Import (C, PQsendQuery, "PQsendQuery"); P : chars_ptr := CS.New_String (Query); R : constant Interfaces.C.int := PQsendQuery (To_Addr (C_Connection), P); begin if R /= 0 then return True; else return False; end if; end SendQuery; procedure GetResult (Res : out Result; Done : out Boolean) is function PQgetResult (Conn : System.Address) return System.Address; pragma Import (C, PQgetResult, "PQgetResult"); R : constant PGResult := To_Result (PQgetResult (To_Addr (C_Connection))); begin if R = Null_Result then Done := True; else Res.Res := R; Done := False; end if; end GetResult; function ConsumeInput return Boolean is function PQconsumeInput (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQconsumeInput, "PQconsumeInput"); R : constant Interfaces.C.Int := PQconsumeInput (To_Addr (C_Connection)); begin if R /= 0 then return True; else return False; end if; end ConsumeInput; function Flush return Boolean is function PQflush (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQflush, "PQflush"); R : constant Interfaces.C.Int := PQflush (To_Addr (C_Connection)); begin if R = 0 then return True; else return False; end if; end Flush; function IsBusy return Boolean is function PQisBusy (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQisBusy, "PQisBusy"); R : constant Interfaces.C.Int := PQisBusy (To_Addr (C_Connection)); begin if R /= 0 then return True; else return False; end if; end IsBusy; function RequestCancel return Boolean is function PQrequestCancel (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQrequestCancel, "PQrequestCancel"); R : constant Interfaces.C.Int := PQrequestCancel (To_Addr (C_Connection)); begin if R /= 0 then return True; else return False; end if; end RequestCancel; function Socket return Interfaces.C.int is function PQsocket (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQsocket, "PQsocket"); R : constant Interfaces.C.Int := PQsocket (To_Addr (C_Connection)); begin return R; end Socket; procedure Notifies (Message : out Notification; Done : out Boolean) is function PQnotifies (Conn : System.Address) return System.Address; pragma Import (C, PQnotifies, "PQnotifies"); procedure Free (Addr : System.Address); pragma Import (C, Free, "free"); type NotiPtr is access all Notification; package P is new System.Address_To_Access_Conversions (Notification); function Cvt is new Ada.Unchecked_Conversion (P.Object_Pointer, NotiPtr); N : NotiPtr; A : constant System.Address := PQnotifies (To_Addr (C_Connection)); begin N := Cvt (P.To_Pointer (A)); if N /= null then Message := N.all; Free (A); Done := False; else Done := True; end if; end Notifies; end PGConn; procedure Initialize (Object : in out Database) is begin null; end Initialize; procedure Finalize (Object : in out Database) is procedure Free is new Ada.Unchecked_Deallocation(PGConn,Connection_Pointer); begin Object.Connection.Close; if Object.Connection /= null then Free( Object.Connection ); end if; end Finalize; function Connect (Params : access String) return Connection_Handle is function PQConnect (Options : char_array) return System.Address; pragma Import (C, PQConnect, "PQconnectdb"); Conn : Connection_Handle; begin Conn := To_Conn (PQConnect (C.To_C (Params.all))); if Conn = Null_Connection then raise PostgreSQL_Error; else return Conn; end if; end Connect; procedure Reset (DB : in Database'Class) is begin DB.Connection.Reset; end Reset; type C_Accessor is access function (Conn : System.Address) return chars_ptr; pragma Convention (C, C_Accessor); generic Accessor : C_Accessor; function Connection_Accessor (DB : in Database'Class) return String; function Connection_Accessor (DB : in Database'Class) return String is begin return CS.Value (Accessor.all (To_Addr (DB.Connection.Handle))); end Connection_Accessor; function PQdb (Conn : System.Address) return chars_ptr; pragma Import (C, PQdb, "PQdb"); function Get_Name is new Connection_Accessor (Accessor => PQdb'access); function PQuser (Conn : System.Address) return chars_ptr; pragma Import (C, PQuser, "PQuser"); function Get_User is new Connection_Accessor (Accessor => PQuser'access); function PQpass (Conn : System.Address) return chars_ptr; pragma Import (C, PQpass, "PQpass"); function Get_Pass is new Connection_Accessor (Accessor => PQpass'access); function PQhost (Conn : System.Address) return chars_ptr; pragma Import (C, PQhost, "PQhost"); function Get_Host is new Connection_Accessor (Accessor => PQhost'access); function PQport (Conn : System.Address) return chars_ptr; pragma Import (C, PQport, "PQport"); function Get_Port is new Connection_Accessor (Accessor => PQport'access); function PQtty (Conn : System.Address) return chars_ptr; pragma Import (C, PQtty, "PQtty"); function Get_TTY is new Connection_Accessor (Accessor => PQtty'access); function PQopt (Conn : System.Address) return chars_ptr; pragma Import (C, PQopt, "PQoptions"); function Get_Options is new Connection_Accessor (Accessor => PQopt'access); function Name (DB : in Database'Class) return String renames Get_Name; function User (DB : in Database'Class) return String renames Get_User; function Password (DB : in Database'Class) return String renames Get_Pass; function Host (DB : in Database'Class) return String renames Get_Host; function Port (DB : in Database'Class) return String renames Get_Port; function TTY (DB : in Database'Class) return String renames Get_TTY; function Options (DB : in Database'Class) return String renames Get_Options; function Error (DB : in Database'Class) return String is begin return DB.Connection.Error; end Error; function Status (DB : in Database'Class) return ConnStatus is begin return DB.Connection.Status; end Status; function Server_PID (DB : in Database'Class) return Backend_PID is begin return DB.Connection.PID; end Server_PID; procedure Execute (Res : out Result; DB : in Database'Class; Query : String) is begin DB.Connection.Execute (Res, Query); end Execute; procedure Make_Empty_Result (Res : out Result; DB : in Database'Class; Status : in ExecStatus := PGRES_EMPTY_QUERY) is begin DB.Connection .Empty_Result (Res, Status); end Make_Empty_Result; procedure Initialize (Object : in out Result) is begin null; end Initialize; procedure Finalize (Object : in out Result) is procedure PQclear (Res : in System.Address); pragma Import (C, PQclear, "PQclear"); begin if Object.Res /= Null_Result then PQclear (To_Addr (Object.Res)); Object.Res := Null_Result; end if; end Finalize; function Status (Res : in Result) return ExecStatus is function PQresStatus (Conn : System.Address) return Interfaces.C.int; pragma Import (C, PQresStatus, "PQresultStatus"); begin return ExecStatus'Val (PQresStatus (To_Addr (Res.Res))); end Status; function Status (Status : in ExecStatus) return String is function PQresStat (stat : Interfaces.C.int) return chars_ptr; pragma Import (C, PQresStat, "PQresStatus"); begin return CS.Value (PQresStat(ExecStatus'Pos (Status))); end Status; function Status (Res : in Result) return String is Stat : constant ExecStatus := Status (Res); begin return Status (Stat); end Status; function Error (Res : in Result) return String is function PQresErr (Res : System.Address) return chars_ptr; pragma Import (C, PQresErr, "PQresultErrorMessage"); begin return CS.Value (PQresErr (To_Addr (Res.Res))); end Error; function Quote_Identifier (Identifier : String) return String is begin return '"' & Identifier & '"'; end Quote_Identifier; type C_Info is access function (Res : System.Address) return C.int; pragma Convention (C, C_Info); generic Accessor : C_Info; function Info_Accessor (Res : in Result) return Integer; function Info_Accessor (Res : in Result) return Integer is begin return Integer (Accessor.all (To_Addr (Res.Res))); end Info_Accessor; function PQntuples (Res : System.Address) return C.int; pragma Import (C, PQntuples, "PQntuples"); function Get_Count is new Info_Accessor (Accessor => PQntuples'access); function PQnfields (Res : System.Address) return C.int; pragma Import (C, PQnfields, "PQnfields"); function Get_FCount is new Info_Accessor (Accessor => PQnfields'access); function PQbinaryTuples (Res : System.Address) return C.int; pragma Import (C, PQbinaryTuples, "PQbinaryTuples"); function Get_BinaryTuples is new Info_Accessor (Accessor => PQbinaryTuples'Access); function Tuple_Count (Res : Result) return Tuple_Index is begin return Tuple_Index (Get_Count (Res)); end Tuple_Count; function Field_Count (Res : Result) return Field_Index is begin return Field_Index (Get_FCount (Res)); end Field_Count; function Field_Name (Res : Result; Index : Field_Index) return String is function PQfname (Res : System.Address; Idx : C.int) return chars_ptr; pragma Import (C, PQfname, "PQfname"); begin return CS.Value (PQfname (To_Addr (Res.Res), C.int (Index))); end Field_Name; procedure Field_Lookup (Res : in Result; Name : in String; Index : out Field_Index; Found : out Boolean) is function PQfnumber (Res : System.Address; Name : chars_ptr) return C.int; pragma Import (C, PQfnumber, "PQfnumber"); P : chars_ptr := CS.New_String (Name); I : constant C.int := PQfnumber (To_Addr (Res.Res), P); begin CS.Free (P); if I < 0 then Found := False; Index := Field_Index'Last; else Found := True; Index := Field_Index (I); end if; end Field_Lookup; function Is_Binary (Res : Result; Index : Field_Index) return Boolean is I : constant Integer := Get_BinaryTuples (Res); begin if I /= 0 then return True; else return False; end if; end Is_Binary; function Field_Type (Res : Result; Index : Field_Index) return TypeID is function PQftype (Res : System.Address; Idx : C.int) return TypeID; pragma Import (C, PQftype, "PQftype"); begin return PQftype (To_Addr (Res.Res), C.Int (index)); end Field_Type; procedure Value (Res : in Result; Tuple : in Tuple_Index; Field : in Field_Index; Pointer : out System.Address) is function Cvt is new Ada.Unchecked_Conversion (chars_ptr, System.Address); function PQgetvalue (Res : System.Address; Tuple : C.int; Field : C.int) return chars_ptr; pragma Import (C, PQgetvalue, "PQgetvalue"); P : constant chars_ptr := PQgetvalue (To_Addr (Res.Res), C.int (Tuple), C.int (Field)); begin Pointer := Cvt (P); end Value; function Value (Res : Result; Tuple : Tuple_Index := 0; Field : Field_Index := 0) return String is function PQgetvalue (Res : System.Address; Tuple : C.int; Field : C.int) return chars_ptr; pragma Import (C, PQgetvalue, "PQgetvalue"); P : constant chars_ptr := PQgetvalue (To_Addr (Res.Res), C.int (Tuple), C.int (Field)); begin if Is_Binary (Res, Field) then raise PostgreSQL_Error; end if; return CS.Value (P); end Value; function Value (Res : Result; Tuple : Tuple_Index := 0; Field_Name : String ) return String is Found : Boolean; Idx : Field_Index; begin Field_Lookup (Res, Field_Name, Idx, Found); if Found then return Value (Res, Tuple, Idx); else raise PostgreSQL_Error; end if; end Value; function Field_Size (Res : Result; Field : Field_Index) return Integer is function PQfsize (Res : System.Address; Idx : C.int) return C.int; pragma Import (C, PQfsize, "PQfsize"); begin return Integer (PQfsize (To_Addr (Res.Res), C.int (Field))); end Field_Size; function Field_Modification (Res : Result; Field : Field_Index) return Integer is function PQfmod (Res : System.Address; Idx : C.int) return C.int; pragma Import (C, PQfmod, "PQfmod"); begin return Integer (PQfmod (To_Addr (Res.Res), C.int (Field))); end Field_Modification; function Field_Length (Res : Result; Tuple : Tuple_Index; Field : Field_Index) return Natural is function PQgetlen (Res : System.Address; Row : C.int; Idx : C.int) return C.int; pragma Import (C, PQgetlen, "PQgetlength"); begin return natural (PQgetlen (To_Addr (Res.Res), C.Int (Tuple), C.int (Field))); end Field_Length; function Is_Null (Res : Result; Tuple : Tuple_Index; Field : Field_Index) return Boolean is use type C.int; function PQisnull (Res : System.Address; Row : C.int; Idx : C.int) return C.int; pragma Import (C, PQisnull, "PQgetisnull"); R : constant C.int := PQisnull (To_Addr (Res.Res), C.Int (Tuple), C.int (Field)); begin if R = 0 then return False; else return True; end if; end Is_Null; function Command_Status (Res : in Result) return String is function PQcmdStatus (Res : System.Address) return chars_ptr; pragma Import (C, PQcmdStatus, "PQcmdStatus"); begin return CS.Value (PQcmdStatus (To_Addr (Res.Res))); end Command_Status; function Command_Tuples (Res : in Result) return String is function PQcmdTuples (Res : System.Address) return chars_ptr; pragma Import (C, PQcmdTuples, "PQcmdTuples"); begin return CS.Value (PQcmdTuples (To_Addr (Res.Res))); end Command_Tuples; function Command_Tuples (Res : in Result) return Natural is S : constant String := Command_Tuples (Res); begin if S = "" then return 0; else return Natural'Value (S); end if; end Command_Tuples; function OID_Value (Res : in Result) return OID is function PQoidValue (Res : System.Address) return OID; pragma Import (C, PQoidValue, "PQoidValue"); begin return PQoidValue (To_Addr (Res.Res)); end OID_Value; -- ----------------------------------------------------------------------- procedure Load_TypeInfo (DB : in Database'Class; Typ : in TypeID := InvalidTypeID; R : out TypeInfo) is begin if Typ = InvalidTypeID then Execute (R, DB, "SELECT * FROM pg_type"); else Execute (R, DB, "SELECT * FROM pg_type WHERE OID=" & TypeID'Image (Typ)); end if; end Load_TypeInfo; function Value (Res : TypeInfo; Tuple : Tuple_Index := 0; Field_Name : String) return String is begin return Value (Result (Res), Tuple, Field_Name); end Value; procedure Set_Non_Blocking (DB : in Database'Class) is begin DB.Connection.SetNonBlocking; end Set_Non_Blocking; function Is_Non_Blocking (DB : in Database'Class) return Boolean is begin return DB.Connection.IsNonBlocking; end Is_Non_Blocking; function Send_Query (DB : in Database'Class; Query : in String) return Boolean is begin return DB.Connection.SendQuery (Query); end Send_Query; procedure Get_Result (DB : in Database'Class; Res : out Result; Done : out Boolean) is begin DB.Connection.GetResult (Res, Done); end Get_Result; function Consume_Input (DB : in Database'Class) return Boolean is begin return DB.Connection.ConsumeInput; end Consume_Input; function Flush (DB : in Database'Class) return Boolean is begin return DB.Connection.Flush; end Flush; function Is_Busy (DB : in Database'Class) return Boolean is begin return DB.Connection.IsBusy; end Is_Busy; function Request_Cancel (DB : in Database'Class) return Boolean is begin return DB.Connection.RequestCancel; end Request_Cancel; function Socket (DB : in Database'Class) return Interfaces.C.Int is begin return DB.Connection.Socket; end Socket; procedure Notifies (DB : in Database'Class; Message : out Notification; Done : out Boolean) is begin DB.Connection.Notifies (Message, Done); end Notifies; end GNU.DB.PostgreSQL; |